diff --git a/CREDITS.txt b/CREDITS.txt new file mode 100644 --- /dev/null +++ b/CREDITS.txt @@ -0,0 +1,19 @@ +AUTHORS + +Daan Leijen, Bastiaan Heeren, Jurriaan Hage + +CREDITS + +The first version of the Lazy Virtual Machine was developed by Daan Leijen +and released as part of the Helium compiler. This version has been adapted +for the release of the lvmlib cabal package and because of changes in +the Haskell infrastructure. + +The following people have contributed to the development and testing of the +Helium compiler and its components: + +Arjan van IJzendoorn, Daan Leijen, Rijk-Jan van Haaften, Arie Middelkoop, +Arjan Oosting, Jurri‘n Stutterheim, Jeroen Fokker, Andres Loeh, +Arthur Baars, Remco Burema, Atze Dijkstra, Maarten van Gompel, +Doaitse Swierstra, Martijn Lammerts, Martijn Schrage and +Stefan Holdermans. diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,24 @@ +Copyright (c) 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage +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 Daan Leijen, Bastiaan Heeren, Jurriaan Hage, nor the + names of its 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 HOLDERS 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/Lvm/Asm/Data.hs b/Lvm/Asm/Data.hs new file mode 100644 --- /dev/null +++ b/Lvm/Asm/Data.hs @@ -0,0 +1,134 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Asm.Data + ( AsmModule, AsmDecl + , Top(..), Atom, Expr(..), Note(..), Occur(..) + , Lit(..), Alt(..), Pat(..), Con(..) + ) where + +import Lvm.Common.Byte +import Lvm.Common.Id +import Lvm.Core.Module +import Text.PrettyPrint.Leijen + +{--------------------------------------------------------------- + Asm modules +---------------------------------------------------------------} +type AsmModule = Module Top +type AsmDecl = Decl Top + +{--------------------------------------------------------------- + low level "assembly" language +---------------------------------------------------------------} +data Top = Top ![Id] Expr -- arguments expression + +type Atom = Expr +data Expr = Eval !Id Expr Expr + | Match !Id ![Alt] + | Prim !Id ![Atom] + -- atomic + | LetRec ![(Id,Atom)] Expr + | Let !Id Atom Expr + | Ap !Id ![Atom] + | Con !(Con Atom) ![Atom] + | Lit !Lit + | Note !Note !Expr + +data Note = Occur !Occur +data Occur = Never | Once | Many + +data Lit = LitInt !Int + | LitFloat !Double + | LitBytes !Bytes + +data Alt = Alt !Pat Expr + +data Pat = PatVar !Id + | PatCon !(Con Int) ![Id] + | PatLit !Lit + +data Con tag = ConId !Id + | ConTag tag !Arity + +{--------------------------------------------------------------- + pretty print Asm expressions +---------------------------------------------------------------} + +instance Pretty Top where + pretty (Top args expr) = + nest 2 (text "\\" <> hsep (map pretty args) <+> text "->" <$> pretty expr) + +{--------------------------------------------------------------- + expressions +---------------------------------------------------------------} + +instance Pretty Expr where + pretty = ppExprWith id + +ppArg :: Expr -> Doc +ppArg = ppExprWith parens + +ppExprWith :: (Doc -> Doc) -> Expr -> Doc +ppExprWith pars expr + = case expr of + Let x atom e -> pars $ align $ hang 3 (text "let" <+> ppBind (x,atom)) <$> (text "in" <+> pretty e) + LetRec binds e -> pars $ align $ hang 7 (text "letrec" <+> vcat (map ppBind binds)) <$> nest 3 (text "in" <+> pretty e) + Eval x e e' -> pars $ align $ hang 7 (text "let!" <+> pretty x <+> text "=" pretty e) + <$> nest 3 (text "in" <+> pretty e') + Match x alts -> pars $ align $ hang 2 (text "match" <+> pretty x <+> text "with" <$> vcat (map pretty alts)) + Prim x args -> pars $ text "prim" <> char '[' <> pretty x <+> hsep (map ppArg args) <> char ']' + Ap x [] -> pretty x + Ap x args -> pars $ pretty x <+> hsep (map ppArg args) + Con con [] -> pretty con + Con con args -> pars $ pretty con <+> hsep (map ppArg args) + Lit lit -> pretty lit + Note note e -> pars $ align $ pretty note pretty e + +instance Pretty a => Pretty (Con a) where + pretty con = + case con of + ConId x -> pretty x + ConTag tag arity -> text "(@" <> pretty tag <> char ',' <> pretty arity <> char ')' + +instance Pretty Note where + pretty (Occur occ) = angles (pretty occ) + +instance Pretty Occur where + pretty Never = text "never" + pretty Once = text "once" + pretty Many = text "many" + +{--------------------------------------------------------------- + alternatives +---------------------------------------------------------------} + +instance Pretty Alt where + pretty (Alt pat expr) = + hang 2 (pretty pat <+> text "->" pretty expr) + +instance Pretty Pat where + pretty pat = + case pat of + PatCon con params -> pretty con <+> hsep (map pretty params) + PatVar x -> pretty x + PatLit lit -> pretty lit + +{--------------------------------------------------------------- + literals and variables +---------------------------------------------------------------} + +instance Pretty Lit where + pretty lit = + case lit of + LitInt i -> pretty i + LitFloat d -> pretty d + LitBytes b -> dquotes (string (stringFromBytes b)) + +ppBind :: Pretty a => (Id, a) -> Doc +ppBind (x, atom) = + pretty x <+> text "=" <+> pretty atom diff --git a/Lvm/Asm/Inline.hs b/Lvm/Asm/Inline.hs new file mode 100644 --- /dev/null +++ b/Lvm/Asm/Inline.hs @@ -0,0 +1,177 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Inline.hs 291 2012-11-08 11:27:33Z heere112 $ +module Lvm.Asm.Inline (asmInline) where + +import Data.Maybe +import Lvm.Asm.Data +import Lvm.Asm.Occur ( asmOccur ) +import Lvm.Common.Id +import Lvm.Common.IdMap + +{--------------------------------------------------------------- + Inline environment maps identifiers to their definition +---------------------------------------------------------------} +type Env = IdMap Expr + +removeIds :: [Id] -> IdMap a -> IdMap a +removeIds = flip (foldr deleteMap) + +{--------------------------------------------------------------- + asmInline +---------------------------------------------------------------} +asmInline :: AsmModule -> AsmModule +asmInline = fmap inlineTop . asmOccur + +inlineTop :: Top -> Top +inlineTop (Top params expr) + = Top params (inlineExpr emptyMap expr) + +inlineExpr :: Env -> Expr -> Expr +inlineExpr env expr + = case expr of + -- dead variable + Let _ (Note (Occur Never) _) e2 + -> inlineExpr env e2 + -- once + Let x (Note (Occur Once) e1) e2 + -> let e1' = inlineExpr env e1 -- de-annotate + in inlineExpr (extendMap x e1' env) e2 + + -- trivial, inline everywhere + Let x e1 e2 | trivial e1 + -> let e1' = inlineExpr env (deAnnotate e1) + in inlineExpr (extendMap x e1' env) e2 + + Eval x e1 e2 | whnfTrivial e1 + -> let e1' = inlineExpr env (deAnnotate e1) + in inlineExpr (extendMap x e1' env) e2 + + -- inline-able let! binding? + Eval x (Note (Occur Once) e1) e2 + -> let e1' = inlineExpr env e1 -- de-annotate + in if firstuse x e2 + -- firstuse is true, we can inline immediately + then let env' = extendMap x (Eval x e1' (Ap x [])) env -- NOTE: should we use a fresh id? + in inlineExpr env' e2 + else let e2' = inlineExpr env e2 + in if firstuse x e2' + -- firstuse became true after inlining! re-inline this definition again (is this too expensive?) + then let env' = extendMap x (Eval x e1' (Ap x [])) emptyMap -- NOTE: should we use a fresh id? + in inlineExpr env' e2' + -- otherwise, don't inline this definition + else Eval x (Note (Occur Once) e1') e2' + + -- basic cases + Let x e1 e2 -> let env' = deleteMap x env + in Let x (inlineExpr env e1) (inlineExpr env' e2) + + Eval x e1 e2 -> let env' = deleteMap x env + in Eval x (inlineExpr env e1) (inlineExpr env' e2) + + LetRec bs e -> let (bs',env') = inlineBinds env bs + in LetRec bs' (inlineExpr env' e) + + Match x alts -> case lookupMap x env of + Just e -> -- trivial inlining of a let! binding leads to this configuration. + -- a case-of-known transformation would actually remove this match. + Eval x (Note (Occur Once) e) (Match x (inlineAlts env alts)) + Nothing -> Match x (inlineAlts env alts) + + Ap x [] -> fromMaybe (Ap x []) (lookupMap x env) + Ap x args -> let args0 = inlineExprs env args + in case lookupMap x env of + Just e -> case e of + Ap id1 args1 -> Ap id1 (args1 ++ args0) -- flatten applications + Eval id1 e1 (Ap id2 []) | id1==id2 -- special case for the strict inliner + -> Eval id1 e1 (Ap id1 args0) + _ -> Let x e (Ap x args) -- don't inline! + Nothing -> Ap x args0 + Con con args -> Con (inlineCon env con) (inlineExprs env args) + Prim x args -> Prim x (inlineExprs env args) + Lit _ -> expr + Note note e -> Note note (inlineExpr env e) + +inlineCon :: Env -> Con Expr -> Con Expr +inlineCon env con + = case con of + ConTag tag arity -> ConTag (inlineExpr env tag) arity + _ -> con + +inlineExprs :: Env -> [Expr] -> [Expr] +inlineExprs env exprs + = [inlineExpr env expr | expr <- exprs] + +inlineBinds :: Env -> [(Id,Expr)] -> ([(Id,Expr)],Env) +inlineBinds env binds + = let env' = removeIds (map fst binds) env + in ([(x,inlineExpr env' e) | (x,e) <- binds], env') + +inlineAlts :: Env -> [Alt] -> [Alt] +inlineAlts env alts + = [inlineAlt env alt | alt <- alts] + +inlineAlt :: IdMap Expr -> Alt -> Alt +inlineAlt env (Alt pat expr) + = Alt pat (inlineExpr (removeIds (patIds pat) env) expr) + where + patIds (PatVar x) = [x] + patIds (PatCon _ xs) = xs + patIds (PatLit _) = [] + + +{--------------------------------------------------------------- + deAnnotate +---------------------------------------------------------------} +deAnnotate :: Expr -> Expr +deAnnotate expr + = case expr of + Note _ e -> deAnnotate e + _ -> expr + +{--------------------------------------------------------------- + trivial +---------------------------------------------------------------} +trivial :: Expr -> Bool +trivial expr + = case expr of + Note _ e -> trivial e + Ap _ [] -> True + Con (ConId _) [] -> True + Lit _ -> True + _ -> False + +whnfTrivial :: Expr -> Bool +whnfTrivial expr + = case expr of + Note _ e -> whnfTrivial e + Con (ConId _) [] -> True + Lit _ -> True + _ -> False + +{--------------------------------------------------------------- + firstuse +---------------------------------------------------------------} + +firstuse :: Id -> Expr -> Bool +firstuse x = first x False + +firsts :: Id -> Bool -> [Expr] -> Bool +firsts = foldl . first + +first :: Id -> Bool -> Expr -> Bool +first x c expr + = case expr of + LetRec bs e -> firsts x c (map snd bs ++ [e]) + Let _ e1 e2 -> firsts x c [e1,e2] + Eval _ e1 _ -> first x False e1 + Match _ _ -> False + Prim _ args -> firsts x False args + Ap y args | null args && y == x -> True + | not (null args) -> firsts x c (Ap y [] : args) + Con _ args -> firsts x c args + Note _ e -> first x c e + _ -> c diff --git a/Lvm/Asm/Occur.hs b/Lvm/Asm/Occur.hs new file mode 100644 --- /dev/null +++ b/Lvm/Asm/Occur.hs @@ -0,0 +1,112 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Occur.hs 291 2012-11-08 11:27:33Z heere112 $ +module Lvm.Asm.Occur (asmOccur) where + +import Lvm.Asm.Data +import Lvm.Common.Id +import Lvm.Common.IdMap + +{--------------------------------------------------------------- + Occ: maps identifiers to the number of syntactic + occurrences +---------------------------------------------------------------} +type Occ = IdMap Int + +addOcc :: Id -> Occ -> Occ +addOcc x = insertMapWith x 1 (+1) + +delOcc :: Id -> IdMap Int -> IdMap Int +delOcc = deleteMap + +unionOcc :: IdMap Int -> IdMap Int -> IdMap Int +unionOcc = unionMapWith (+) + +unionOccs :: [IdMap Int] -> IdMap Int +unionOccs = foldr unionOcc emptyMap + +occur :: Id -> Occ -> Occur +occur x occ + = case lookupMap x occ of + Just 0 -> Never + Just 1 -> Once + Just _ -> Many + Nothing -> Never + +{--------------------------------------------------------------- + asmOccur: annotate every Eval and Let binding with + the number of syntactic occurrences. +---------------------------------------------------------------} +asmOccur :: AsmModule -> AsmModule +asmOccur = fmap occTop + +occTop :: Top -> Top +occTop (Top x expr) + = let (expr', _) = occExpr expr + in Top x expr' + +occExpr :: Expr -> (Expr,Occ) +occExpr expr + = case expr of + -- TODO: if we determine that a let bound variable is never used, + -- we can delete occurrences in its definition *if* an inliner + -- removes all dead let bindings. This would make the occurrence + -- analysis more precise + Eval x e1 e2 -> let (e1',occ1) = occExpr e1 + (e2',occ2) = occExpr e2 + occ = unionOcc occ1 occ2 + in (Eval x (Note (Occur (occur x occ)) e1') e2', delOcc x occ) + Let x e1 e2 -> let (e2',occ2) = occExpr e2 + (e1',occ1) = occExpr e1 + occ = unionOcc occ1 occ2 + in (Let x (Note (Occur (occur x occ)) e1') e2', delOcc x occ) + LetRec bs e -> let (e',occ1) = occExpr e + (ids,es) = unzip bs + (es',occ2) = occExprs es + occ = unionOcc occ1 occ2 + bs' = [(x, Note (Occur (occur x occ)) e2) | (x,e2) <- zip ids es'] + in (LetRec bs' e', foldr delOcc occ ids) + + Match x alts -> let (alts',occ) = occAlts alts + in (Match x alts',addOcc x occ) + Ap x atoms -> let (atoms',occ) = occExprs atoms + in (Ap x atoms',addOcc x occ) + Con con atoms -> let (atoms',occ1) = occExprs atoms + (con',occ2) = occCon con + in (Con con' atoms',unionOcc occ1 occ2) + Prim x atoms -> let (atoms',occ) = occExprs atoms + in (Prim x atoms',occ) + Lit _ -> (expr,emptyMap) + Note note e -> let (expr',occ) = occExpr e + in (Note note expr',occ) + +occCon :: Con Expr -> (Con Expr, Occ) +occCon con + = case con of + ConTag tag arity -> let (tag',occ) = occExpr tag in (ConTag tag' arity,occ) + _ -> (con,emptyMap) + +occExprs :: [Expr] -> ([Expr],Occ) +occExprs exprs + = let (exprs',occs) = unzip (map occExpr exprs) + in (exprs',unionOccs occs) + +occAlts :: [Alt] -> ([Alt], IdMap Int) +occAlts alts + = let (alts',occs) = unzip (map occAlt alts) + in (alts',unionOccs occs) + +occAlt :: Alt -> (Alt, IdMap Int) +occAlt (Alt pat expr) + = let (expr',occ) = occExpr expr + in (Alt pat expr',foldr delOcc occ (patIds pat)) + where + patIds (PatVar x) = [x] + patIds (PatCon _ ids) = ids + patIds (PatLit _) = [] + + + diff --git a/Lvm/Asm/ToLvm.hs b/Lvm/Asm/ToLvm.hs new file mode 100644 --- /dev/null +++ b/Lvm/Asm/ToLvm.hs @@ -0,0 +1,324 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: ToLvm.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Asm.ToLvm (asmToLvm) where + +import Control.Exception ( assert ) +import Data.List +import Lvm.Asm.Data +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Data +import Lvm.Instr.Data hiding ( Con(..), Alt(..), Pat(..) ) +import Lvm.Instr.Resolve (instrResolve) +import Lvm.Instr.Rewrite (instrRewrite) +import qualified Lvm.Asm.Data as Asm +import qualified Lvm.Instr.Data as Instr + +{--------------------------------------------------------------- + asmToLvm: generate instructions from Asm expressions +---------------------------------------------------------------} +asmToLvm :: AsmModule -> LvmModule +asmToLvm m = fmap (codegen (initialEnv m)) m + +codegen :: Env -> Top -> [Instr] +codegen env = instrRewrite . instrResolve . cgTop env + +{--------------------------------------------------------------- + top-level declarations +---------------------------------------------------------------} +cgTop :: Env -> Top -> [Instr] +cgTop env (Top params expr) + = [ARGCHK (length params)] ++ [ATOM (cgParams env params ++ cgExpr env expr)] ++ [ENTER] + +cgParams :: Env -> [Id] -> [Instr] +cgParams _ = map PARAM . reverse + +{--------------------------------------------------------------- + expressions +---------------------------------------------------------------} +cgExpr :: Env -> Expr -> [Instr] +cgExpr env expr + = case expr of + -- optimized schemes + Eval id1 (Note (Occur Once) e1) (Match id2 alts) | id1 == id2 && whnf env e1 + -> ATOM (cgExpr env e1) : cgMatch env alts + Eval id1 (Note (Occur Once) e1) (Match id2 alts) | id1 == id2 + -> EVAL 0 [ATOM (cgExpr env e1),ENTER] : cgMatch env alts + Eval x e1 e2 | whnf env e1 + -> [ATOM (cgExpr env e1),VAR x] ++ cgExpr env e2 + Eval id1 e1 (Ap id2 []) | id1 == id2 + -> cgExpr env e1 + + -- basic cases + LetRec binds e -> cgLetRec env binds ++ cgExpr env e + Let x atom e -> cgLet env x atom ++ cgExpr env e + Eval x e1 e2 -> [EVAL 0 [ATOM (cgExpr env e1),ENTER],VAR x] ++ cgExpr env e2 + Match x alts -> cgVar env x ++ cgMatch env alts + Prim x args -> cgPrim env x args + Note _ e -> cgExpr env e + atom -> cgAtom env atom + +{--------------------------------------------------------------- + let bindings +---------------------------------------------------------------} + +cgLet :: Env -> Id -> Expr -> [Instr] +cgLet env x atom = cgAtom env atom ++ [VAR x] + +cgLetRec :: Env -> [(Id, Atom)] -> [Instr] +cgLetRec env binds = concat (map (cgAlloc env) binds ++ map (cgInit env) binds) + +cgAlloc :: Env -> (Id, Atom) -> [Instr] +cgAlloc env (x,atom) = [ATOM (cgAlloc' env atom),VAR x] + +cgAlloc' :: Env -> Atom -> [Instr] +cgAlloc' env atom + = case atom of + Asm.Ap _ args -> [ALLOCAP (length args + 1)] + Asm.Let _ _ e2 -> cgAlloc' env e2 + Asm.LetRec _ e2 -> cgAlloc' env e2 + Asm.Note _ e -> cgAlloc' env e + Asm.Con (ConId x) args + -> [ALLOCCON (conFromId x (length args) env)] + Asm.Con (ConTag tag arity) args -- TODO: tag may not be recursively bound! + -> assert (arity == length args) $ -- "AsmToCode.cgAlloc': constructor arity doesn't match arguments" + [PUSHINT arity] ++ cgAtom env tag ++ [ALLOC] + Asm.Lit _ -> error "AsmToCode.cgAlloc': literal in recursive binding." + _ -> error "AsmToCode.cgAlloc': non-atomic expression encountered." + +cgInit :: Env -> (Id, Atom) -> [Instr] +cgInit env (x,atom) = [INIT (cgInit' env x atom)] + +cgInit' :: Env -> Id -> Atom -> [Instr] +cgInit' env x atom + = case atom of + Asm.Ap y args -> cgArgs env args ++ cgVar env y ++ [PACKAP (varFromId x) (length args + 1)] + Asm.Let y e1 e2 -> cgLet env y e1 ++ cgInit' env y e2 + Asm.LetRec bs e2 -> cgLetRec env bs ++ cgInit' env x e2 + Asm.Note _ e -> cgInit' env x e + Asm.Con (ConId y) args + -> cgArgs env args ++ [PACKCON (conFromId y (length args) env) (varFromId x)] + Asm.Con (ConTag _ arity) args + -> cgArgs env args ++ [PACK arity (varFromId x)] + Asm.Lit _ -> error "AsmToCode.cgInit: literal in recursive binding." + _ -> error "AsmToCode.cgInit: non-atomic expression encountered." + + + +{--------------------------------------------------------------- + alternatives + result alternatives are 'normalized': the default alternative + is always there and comes first. +---------------------------------------------------------------} + +cgMatch :: Env -> [Alt] -> [Instr] +cgMatch env alts + = case partition isVarAlt alts of + ([],as) -> cgAlts env (Instr.Alt Instr.PatDefault []) as + ([alt],as) -> cgAlts env (cgAlt env alt) as + _ -> error "AsmToCode.cgMatch: multiple default patterns" + where + isVarAlt (Alt (PatVar _) _) = True + isVarAlt _ = False + +cgAlts :: Env -> Instr.Alt -> [Alt] -> [Instr] +cgAlts env def alts + | all isConIdAlt alts = [MATCHCON (def:map (cgAlt env) alts)] + | all isConAlt alts = [MATCH (def:map (cgAltTag env) alts)] + | all isIntAlt alts = [MATCHINT (def:map (cgAlt env) alts)] + | otherwise = error "AsmToCode.cgMatch: unknown or mixed type patterns" + where + isConIdAlt (Alt (PatCon (ConId _) _) _) = True + isConIdAlt _ = False + + isConAlt (Alt (PatCon _ _) _) = True + isConAlt _ = False + + isIntAlt (Alt (PatLit (LitInt _)) _) = True + isIntAlt _ = False + +cgAlt :: Env -> Alt -> Instr.Alt +cgAlt env (Alt pat expr) + = case pat of + PatCon (ConId x) params + -> Instr.Alt (Instr.PatCon (conFromId x (length params) env)) + [ATOM (map PARAM (reverse params) ++ cgExpr env expr)] + PatLit (LitInt i) + -> Instr.Alt (Instr.PatInt i) [ATOM (cgExpr env expr)] + PatVar x + -> Instr.Alt Instr.PatDefault [ATOM (PARAM x : cgExpr env expr)] + _ + -> error "AsmToCode.cgAlt: unknown pattern" + +cgAltTag :: Env -> Alt -> Instr.Alt +cgAltTag env (Alt pat expr) + = case pat of + PatCon (ConTag tag arity) params + -> Instr.Alt (Instr.PatTag tag arity) + [ATOM (map PARAM (reverse params) ++ cgExpr env expr)] + PatCon (ConId x) params + -> let (tag,arity) = tagArityFromId x (length params) env + in Instr.Alt (Instr.PatTag tag arity) + [ATOM (map PARAM (reverse params) ++ cgExpr env expr)] + PatVar x + -> Instr.Alt Instr.PatDefault [ATOM (PARAM x : cgExpr env expr)] + _ + -> error "AsmToCode.cgAltTag: invalid pattern" + +{--------------------------------------------------------------- + primitives +---------------------------------------------------------------} + +cgPrim :: Env -> Id -> [Atom] -> [Instr] +cgPrim env x args + = case lookupInstr x env of + Nothing -> case lookupGlobal x env of + Nothing -> error ("AsmToCode.cgPrim: unknown primitive " ++ show x) + Just arity -> if arity /= length args + then error ("AsmToCode.cgPrim: unsaturated primitive " ++ show x) + else result (CALL (Global x 0 arity)) + Just instr + | isCATCH instr -> case args of + [handler,atom] -> let y = idFromString "@catch@" in + cgAtom env handler ++ + [CATCH [EVAL 0 (cgAtom env atom ++[ENTER]),VAR y]] + _ -> error "AsmToCode.cgPrim: CATCH expects 2 arguments" + | otherwise -> result instr + where + result instr = [ATOM (cgArgs env args ++ [instr])] + +{--------------------------------------------------------------- + atomic expressions +---------------------------------------------------------------} + +cgAtom :: Env -> Expr -> [Instr] +cgAtom env atom = [ATOM (cgAtom' env atom)] + +cgAtom' :: Env -> Expr -> [Instr] +cgAtom' env atom + = case atom of + Ap x args -> cgArgs env args ++ cgVar env x ++ + (if null args then [] else [NEWAP (length args + 1)]) + Lit lit -> cgLit lit + Let x e1 e2 -> cgLet env x e1 ++ cgAtom' env e2 + LetRec bs e2 -> cgLetRec env bs ++ cgAtom' env e2 + Note _ e -> cgAtom' env e + Con (ConId x) args + -> cgArgs env args ++ [NEWCON (conFromId x (length args) env) ] + Con (ConTag tag arity) args + -> cgArgs env args ++ cgAtom env tag ++ [NEW arity] + + -- optimizer: inlined strict bindings + Eval x e1 e2 | whnf env e1 + -> [ATOM (cgExpr env e1), VAR x] ++ cgAtom' env e2 + Eval x e1 e2 + -> [EVAL 0 [ATOM (cgExpr env e1), ENTER], VAR x] ++ cgAtom' env e2 + + + _ -> error "AsmToCode.cgAtom: non-atomic expression encountered" + +cgArgs :: Env -> [Atom] -> [Instr] +cgArgs env args + = concatMap (cgAtom env) (reverse args) + + +{--------------------------------------------------------------- + literals and variables +---------------------------------------------------------------} + +cgLit :: Lit -> [Instr] +cgLit lit + = case lit of + LitInt i -> [PUSHINT i] + LitFloat d -> [PUSHFLOAT d] + LitBytes b -> [PUSHBYTES b 0] + +cgVar :: Env -> Id -> [Instr] +cgVar env x + = case lookupGlobal x env of + Nothing -> [PUSHVAR (varFromId x)] + Just arity -> [PUSHCODE (Global x 0 arity)] + +{--------------------------------------------------------------- + whnf: returns True when the expression puts a weak head normal form + value on the stack. +---------------------------------------------------------------} + +whnf :: Env -> Expr -> Bool +whnf env expr + = case expr of + LetRec _ e -> whnf env e + Let _ _ e2 -> whnf env e2 + Eval _ _ e2 -> whnf env e2 + Match _ alts -> all (whnfAlt env) alts + Prim x _ -> whnfPrim env x + Ap {} -> False + Con {} -> True + Lit {} -> True + Note _ e -> whnf env e + +whnfAlt :: Env -> Alt -> Bool +whnfAlt env (Alt _ e) = whnf env e + +whnfPrim :: Env -> Id -> Bool +whnfPrim env x + = case lookupInstr x env of + Nothing -> False -- TODO: look at the type of a primitive + Just instr -> strictResult instr + + +{--------------------------------------------------------------- + the code generation environment +---------------------------------------------------------------} +data Env = Env { aritiesMap :: IdMap Arity + , instrsMap :: IdMap Instr + , consMap :: IdMap (Tag,Arity) + } + +lookupInstr :: Id -> Env -> Maybe Instr +lookupInstr x = lookupMap x . instrsMap + +lookupGlobal :: Id -> Env -> Maybe Arity +lookupGlobal x = lookupMap x . aritiesMap + +varFromId :: Id -> Var +varFromId x = Var x 0 0 + +conFromId :: Id -> Arity -> Env -> Instr.Con +conFromId x argcount env + = let (tag,arity) = tagArityFromId x argcount env + in Instr.Con x 0 arity tag + +tagArityFromId :: Id -> Arity -> Env -> (Tag, Arity) +tagArityFromId x argcount env + = case lookupMap x (consMap env) of + Just (tag,arity) -> if arity /= argcount + then error ("AsmToCode.conFromId: unsaturated constructor " ++ show x) + else (tag,arity) + Nothing -> error ("AsmToCode.conFromId: undeclared constructor " ++ show x) + +-- create an initial environment from the declarations +initialEnv :: AsmModule -> Env +initialEnv asmMod = Env globals instrs cons + where + globals = mapFromList [(declName d,getArity d) | d <- moduleDecls asmMod + , isDeclValue d || isDeclAbstract d || isDeclExtern d ] + + instrs = mapFromList [(declName d,instrFromEx d) | d <- moduleDecls asmMod + , isDeclExtern d, externCall d == CallInstr] + + cons = mapFromList [(declName d,(conTag d,declArity d)) | d <- moduleDecls asmMod + , isDeclCon d] + + getArity (DeclValue{valueValue=Top args _}) = length args + getArity decl = declArity decl + + instrFromEx x = case externName x of + Plain s -> instrFromName s + Decorate s -> instrFromName s + Ordinal i -> instrFromOpcode i diff --git a/Lvm/Common/Byte.hs b/Lvm/Common/Byte.hs new file mode 100644 --- /dev/null +++ b/Lvm/Common/Byte.hs @@ -0,0 +1,148 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Byte.hs 291 2012-11-08 11:27:33Z heere112 $ +module Lvm.Common.Byte + ( Byte, Bytes + , Monoid(..), unit, isEmpty + , bytesLength, writeBytes, bytesFromList, listFromBytes + , bytesFromString, stringFromBytes, bytesFromInt32, byteFromInt8 + , readByteList, int32FromByteList, stringFromByteList, bytesFromByteList + ) where + +import qualified Control.Exception as CE (catch, IOException) +import Data.Monoid +import Data.Word +import System.Exit +import System.IO + +{---------------------------------------------------------------- + types +----------------------------------------------------------------} +type Byte = Word8 + +data Bytes = Nil + | Cons Byte !Bytes -- Byte is not strict since LvmWrite uses it lazily right now. + | Cat !Bytes !Bytes + +instance Show Bytes where + show bs = show (listFromBytes bs) + +instance Eq Bytes where + bs1 == bs2 = listFromBytes bs1 == listFromBytes bs2 + +{---------------------------------------------------------------- + conversion to bytes +----------------------------------------------------------------} +byteFromInt8 :: Int -> Byte +byteFromInt8 = toEnum + +intFromByte :: Byte -> Int +intFromByte = fromEnum + +bytesFromString :: String -> Bytes +bytesFromString + = bytesFromList . map (toEnum . fromEnum) + +stringFromBytes :: Bytes -> String +stringFromBytes + = map (toEnum . fromEnum) . listFromBytes + +bytesFromInt32 :: Int -> Bytes -- 4 byte big-endian encoding +bytesFromInt32 i + = let n0 = if i < 0 then max32+i+1 else i + n1 = div n0 256 + n2 = div n1 256 + n3 = div n2 256 + xs = map (byteFromInt8 . flip mod 256) [n3,n2,n1,n0] + in bytesFromList xs + +max32 :: Int +max32 = 2^(32::Int) -1 -- Bastiaan (Todo: check) + +{---------------------------------------------------------------- + Byte lists +----------------------------------------------------------------} + +instance Monoid Bytes where + mempty = Nil + mappend bs Nil = bs + mappend Nil cs = cs + mappend bs cs = Cat bs cs + +isEmpty :: Bytes -> Bool +isEmpty Nil = True +isEmpty (Cons _ _) = False +isEmpty (Cat bs cs) = isEmpty bs && isEmpty cs + +unit :: Byte -> Bytes +unit = (`Cons` Nil) + +listFromBytes :: Bytes -> [Byte] +listFromBytes = loop [] + where + loop next bs + = case bs of + Nil -> next + Cons b xs -> b:loop next xs + Cat xs ys -> loop (loop next ys) xs + +bytesFromList :: [Byte] -> Bytes +bytesFromList = foldr Cons Nil + +bytesLength :: Bytes -> Int +bytesLength = loop 0 + where + loop n bs + = case bs of + Nil -> n + Cons _ xs -> (loop $! (n+1)) xs + Cat xs ys -> loop (loop n ys) xs + +writeBytes :: FilePath -> Bytes -> IO () +writeBytes path bs + = do{ h <- openBinaryFile path WriteMode + ; writeHandle h bs + ; hClose h + + } + +writeHandle :: Handle -> Bytes -> IO () +writeHandle h bs + = case bs of + Nil -> return () + Cons b xs -> do{ hPutChar h (toEnum (fromEnum b)); writeHandle h xs } + Cat xs ys -> do{ writeHandle h xs; writeHandle h ys } + + +{---------------------------------------------------------------- + Byte lists +----------------------------------------------------------------} +int32FromByteList :: [Byte] -> (Int,[Byte]) +int32FromByteList bs + = case bs of + n3:n2:n1:n0:cs -> let i = int32FromByte4 n3 n2 n1 n0 in seq i (i,cs) + _ -> error "Byte.int32FromBytes: invalid byte stream" + +int32FromByte4 :: Byte -> Byte -> Byte -> Byte -> Int +int32FromByte4 n0 n1 n2 n3 + = (intFromByte n0*16777216) + (intFromByte n1*65536) + (intFromByte n2*256) + intFromByte n3 + + +stringFromByteList :: [Byte] -> String +stringFromByteList = map (toEnum . fromEnum) + +bytesFromByteList :: [Byte] -> Bytes +bytesFromByteList = bytesFromList + +readByteList :: FilePath -> IO [Byte] +readByteList path + = do{ h <- openBinaryFile path ReadMode + ; xs <- hGetContents h + ; seq (last xs) (hClose h) + ; return (map (toEnum . fromEnum) xs) + } `CE.catch` (\exception -> + let message = show (exception :: CE.IOException) ++ "\n\nUnable to read from file " ++ show path + in do { putStrLn message; exitWith (ExitFailure 1) }) diff --git a/Lvm/Common/Id.hs b/Lvm/Common/Id.hs new file mode 100644 --- /dev/null +++ b/Lvm/Common/Id.hs @@ -0,0 +1,310 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Id.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Common.Id + ( Id + -- essential used in "asm" and "lvm" + , stringFromId, idFromString, idFromStringEx, dummyId + -- exotic: only used in the core compiler + , freshIdFromId, getNameSpace, setNameSpace, NameSupply, newNameSupply + , splitNameSupply, splitNameSupplies, freshId, mapWithSupply + -- very exotic: only used internally for IdMap's that use IntMap + , intFromId, idFromInt + ) where + +import Data.IORef +import Data.Int (Int32) +import Data.List +import System.IO.Unsafe +import Text.PrettyPrint.Leijen +import qualified Data.IntMap as IntMap + +---------------------------------------------------------------- +-- Types +---------------------------------------------------------------- +newtype Id = Id Int32 + +intFromId :: Id -> Int +intFromId (Id i) = fromIntegral i +idFromInt :: Int -> Id +idFromInt i = Id (fromIntegral i) + +---------------------------------------------------------------- +-- Names: the symbol table +---------------------------------------------------------------- +data Names = Names Int (IntMap.IntMap [String]) + +namesRef :: IORef Names +namesRef = unsafePerformIO (newIORef emptyNames) + +emptyNames :: Names +emptyNames = Names 0 IntMap.empty + +idFromString :: String -> Id +idFromString = idFromStringEx (0::Int) + +idFromStringEx :: Enum a => a -> String -> Id +idFromStringEx ns name + = unsafePerformIO $ + do{ names <- readIORef namesRef + ; let (x, names') = insertName (fromEnum ns) name names + ; writeIORef namesRef names' + ; return x + } + +stringFromId :: Id -> String +stringFromId x@(Id i) + | isUniq i = '.' : show (extractUniq i) + | otherwise = unsafePerformIO $ + do{ names <- readIORef namesRef + ; case lookupId x names of + Nothing -> error "Id.nameFromId: unknown id" + Just name -> return name + } + + +---------------------------------------------------------------- +-- fresh identifiers without a nice name +-- but the advantage of a pure interface +---------------------------------------------------------------- +newtype NameSupply = NameSupply (IORef Int32) + +newNameSupply :: IO NameSupply +newNameSupply + = do{ ref <- newIORef 0 + ; return (NameSupply ref) + } + +splitNameSupply :: NameSupply -> (NameSupply,NameSupply) +splitNameSupply supply = (supply,supply) + +splitNameSupplies :: NameSupply -> [NameSupply] +splitNameSupplies = repeat + +freshIdFromId :: Id -> NameSupply -> (Id,NameSupply) +freshIdFromId x supply@(NameSupply ref) + = unsafePerformIO (do{ i <- readIORef ref + ; writeIORef ref (i+1) + ; let name = stringFromId x ++ "." ++ show i + x1 = idFromString name + x2 = setNameSpace (getNameSpace x :: Int) x1 + ; seq name $ seq x2 $ return (x2,supply) + }) + +freshId :: NameSupply -> (Id,NameSupply) +freshId supply@(NameSupply ref) + = unsafePerformIO (do{ i <- readIORef ref + ; writeIORef ref (i+1) + ; return (Id (initUniq i), supply) + }) + +mapWithSupply :: (NameSupply -> a -> b) -> NameSupply -> [a] -> [b] +mapWithSupply f = zipWith f . splitNameSupplies + +---------------------------------------------------------------- +-- Bit masks used within an Id +-- +-- 0x | 0 0 0 0 | 0 0 0 0 | +-- | | F E | sort (=namespace) of the id (TODO: just 128 entries is too few) +-- | F | F F | hash index in the hash table +-- | 7 F F | | index in the list of id's in the leaves of the hash table +-- | | 1 | unique id (no name available) +-- | 7 F F F | F F | unique number of unique id +---------------------------------------------------------------- +dummyId :: Id +dummyId = Id 0x7FFFFFF1 + +shiftSort, maxSort :: Int32 +shiftSort = 0x00000002 +maxSort = 0x7F + +maxHash, shiftHash :: Int32 +maxHash = 0xFFF +shiftHash = 0x00000100 + +shiftIdx, maxIdx :: Int32 +shiftIdx = 0x00100000 +maxIdx = 0x7FF + +shiftUniq,maxUniq :: Int32 +shiftUniq = 0x00000100 +maxUniq = 0x007FFFFF +-- flagUniq = 0x00000001 + +extractBits, clearBits, initBits :: Int32 -> Int32 -> Int32 -> Int32 +extractBits shift maxb i + = (i `div` shift) `mod` (maxb+1) + +clearBits shift maxb i + = i - (extractBits shift maxb i * shift) + +initBits shift v i + = i + (shift * v) + +extractSort :: Int32 -> Int32 +extractSort = extractBits shiftSort maxSort + +clearSort :: Int32 -> Int32 +clearSort = clearBits shiftSort maxSort + +initSort :: Int32 -> Int32 -> Int32 +initSort = initBits shiftSort + +extractHash :: Int32 -> Int32 +extractHash = extractBits shiftHash maxHash + +initHash :: Int32 -> Int32 +initHash h = initBits shiftHash h 0 + +extractIdx :: Int32 -> Int32 +extractIdx = extractBits shiftIdx maxIdx + +initIdx :: Int32 -> Int32 -> Int32 +initIdx = initBits shiftIdx + +extractUniq :: Int32 -> Int32 +extractUniq = extractBits shiftUniq maxUniq + +initUniq :: Int32 -> Int32 +initUniq u = initBits shiftUniq u 1 + +isUniq :: Int32 -> Bool +isUniq = odd + +---------------------------------------------------------------- +-- The core of the symbol table: lookupId and insertName +---------------------------------------------------------------- +instance Eq Id where + Id i1 == Id i2 = i1 == i2 + +-- fast, but predictable +instance Ord Id where + compare x1@(Id i1) x2@(Id i2) = + case compare (extractHash i1) (extractHash i2) of + LT -> LT + EQ | i1 == i2 -> EQ + | otherwise -> compare (stringFromId x1) (stringFromId x2) + GT -> GT + +instance Show Id where + show x = "\"" ++ stringFromId x ++ "\"" + +instance Pretty Id where + pretty = string . stringFromId + +getNameSpace :: Enum a => Id -> a +getNameSpace (Id i) + = toEnum (fromIntegral (extractSort i)) + +setNameSpace :: Enum a => a -> Id -> Id +setNameSpace srt (Id i) + | s > maxSort = error "Id.setIdSort: sort index out of range" + | otherwise = Id (initSort s (clearSort i)) + where + s = fromIntegral (fromEnum srt) + + +lookupId :: Id -> Names -> Maybe String +lookupId (Id i) (Names _ m) + = let idx = extractIdx i + h = extractHash i + in case IntMap.lookup (fromIntegral h) m of + Nothing -> Nothing + Just xs -> Just (index idx xs) + where + index 0 (x:_) = x + index idx (_:xx) = index (idx-1) xx + index _ [] = error "Id.lookupId: corrupted symbol table" + +insertName :: Int -> String -> Names -> (Id, Names) +insertName srt name names + = let (x, names') = insertName' name names + in (setNameSpace srt x, names') + +insertName' :: String -> Names -> (Id,Names) +insertName' name (Names fresh m) + | idx > maxIdx = error ("Id.insertName: too many names with the same hash value (" ++ show name ++ ")") + | otherwise = (Id (initIdx idx h), Names fresh m1) + where + hname = hash name + h = initHash hname + (old, m1) = IntMap.insertLookupWithKey upd (fromIntegral hname) [name] m + (idx, new) = maybe (0, [name]) (insertIdx name) old + upd _ _ _ = new + +-- [insertIdx] returns the index of an element if it exists already, or +-- appends the element and returns its index. +insertIdx :: Eq a => a -> [a] -> (Int32,[a]) +insertIdx y = walk 0 + where + walk idx [] = (idx,[y]) + walk idx xs@(x:xx) | x == y = (idx,xs) + | otherwise = let (idx',xx') = walk (idx+1) xx + in (idx',x:xx') + +---------------------------------------------------------------- +-- Hashing +---------------------------------------------------------------- +hash :: String -> Int32 +hash name + = (hashx name `mod` prime) `mod` maxHash + where + prime = 32537 --65599 -- require: prime < maxHash + + +-- simple hash function that performs quite good in practice +hashx :: String -> Int32 +hashx = foldl' gobble 0 + where + gobble n c = n*65599 + fromIntegral (fromEnum c) + +----------------------------------------------------------------------------- +{- +import Bits +import Word + +-- the [hashpjw] algorithm, see dragon book, section 7.6, page 436. +hashpjw :: String -> Int +hashpjw name + = word32ToInt (foldlStrict gobble (intToWord32 0) name) + where + gobble n c = let h = (shiftL n 4) + intToWord32 (fromEnum c) + high = shiftR h 24 + g = shiftL high 24 + in if (g /= 0) + then xor (xor h high) g + else h +-} + +{- +primes xs = case xs of + [] -> [] + (x:xx) -> x:primes (filter ((/=0).(`mod`x)) xx) + +-} + +{- +,32537,32561,32563,32569,32573,32579,32587,32603,32609,32611,32621,32633,32647,3 +2653,32687,32693,32707,32713,32717,32719,32749,32771,32779,32783,32789,32797,328 +01,32803,32831,32833,32839,32843,32869,32887,32909,32911,32917,32933,32939,32941 +,32957,32969,32971,32983,32987,32993,32999,33013,33023,33029,33037,33049,33053,3 +3071,33073,33083,33091,33107,33113,33119,33149,33151,33161,33179,33181,33191,331 +99,33203,33211,33223,33247,33287,33289,33301,33311,33317,33329,33331,33343,33347 +,33349,33353,33359,33377,33391,33403,33409,33413,33427,33457,33461,33469,33479,3 +3487,33493,33503,33521,33529,33533,33547,33563,33569,33577,33581,33587,33589,335 +99,33601,33613,33617,33619,33623,33629,33637,33641,33647,33679,33703,33713,33721 + +,50891,50893,50909,50923,50929,50951,50957,50969,50971,50989,50993,51001,51031,5 +1043,51047,51059,51061,51071,51109,51131,51133,51137,51151,51157,51169,51193,511 +97,51199,51203,51217,51229,51239,51241,51257,51263,51283,51287,51307,51329,51341 +,51343,51347,51349,51361,51383,51407,51413,51419,51421,51427,51431,51437,51439,5 +1449,51461,51473,51479,51481,51487,51503,51511,51517,51521,51539,51551,51563,515 +77,51581,51593,51599,51607,51613,51631,51637,51647,51659,51673,51679,51683,51691 +,51713,51719,51721,51749,51767,51769,51787,51797,51803,51817,51827,51829,51839,5 +1853,51859,51869,51871,51893,51899,51907,51913,51929,51941,51949,51971,51973,519 +77,51991,52009,52021,52027 +-} diff --git a/Lvm/Common/IdMap.hs b/Lvm/Common/IdMap.hs new file mode 100644 --- /dev/null +++ b/Lvm/Common/IdMap.hs @@ -0,0 +1,129 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: IdMap.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Common.IdMap + ( IdMap, Id + -- essential: used by "Asm" and "Lvm" + , emptyMap, singleMap, elemMap, mapMap, insertMap, extendMap + , insertMapWith, lookupMap, findMap, filterMap, listFromMap + , mapMapWithId, unionMap, unionMapWith, updateMap + -- exotic: used by core compiler + , foldMap, deleteMap, filterMapWithId, mapFromList + , unionMaps, diffMap, unionlMap, foldMapWithId + , isEmptyMap, sizeMap + ) where + +import Data.List +import Data.Maybe +import qualified Data.IntMap as IntMap +import Lvm.Common.Id +import Control.Arrow (first) + +---------------------------------------------------------------- +-- IdMap +---------------------------------------------------------------- +newtype IdMap a = IdMap (IntMap.IntMap a) + +emptyMap :: IdMap a +emptyMap = IdMap IntMap.empty + +singleMap :: Id -> a -> IdMap a +singleMap x a = insertMap x a emptyMap + +isEmptyMap :: IdMap a -> Bool +isEmptyMap (IdMap m) = IntMap.null m + + +elemMap :: Id -> IdMap a -> Bool +elemMap x (IdMap m) + = IntMap.member (intFromId x) m + +mapMap :: (a -> b) -> IdMap a -> IdMap b +mapMap f (IdMap m) + = IdMap (IntMap.map f m) + +mapMapWithId :: (Id -> a -> b) -> IdMap a -> IdMap b +mapMapWithId f (IdMap m) + = IdMap (IntMap.mapWithKey (\i x -> f (idFromInt i) x) m) + + +insertMap :: Id -> a -> IdMap a -> IdMap a +insertMap x a (IdMap m) + = IdMap (IntMap.insertWith err (intFromId x) a m) + where + err _ _ = error ("IdMap.insertMap: duplicate id " ++ show x) + +insertMapWith :: Id -> a -> (a -> a) -> IdMap a -> IdMap a +insertMapWith x a f (IdMap m) + = IdMap (IntMap.insertWith (const f) (intFromId x) a m) + +updateMap :: Id -> a -> IdMap a -> IdMap a +updateMap x a (IdMap m) + = IdMap (IntMap.insertWith const (intFromId x) a m) + +deleteMap :: Id -> IdMap a -> IdMap a +deleteMap x(IdMap m) + = IdMap (IntMap.delete (intFromId x) m) + +extendMap :: Id -> a -> IdMap a -> IdMap a +extendMap x a (IdMap m) + = IdMap (IntMap.insertWith const (intFromId x) a m) + +lookupMap :: Id -> IdMap a -> Maybe a +lookupMap x (IdMap m) + = IntMap.lookup (intFromId x) m + +filterMap :: (a -> Bool) -> IdMap a -> IdMap a +filterMap p (IdMap m) + = IdMap (IntMap.filter p m) + +filterMapWithId :: (Id -> a -> Bool) -> IdMap a -> IdMap a +filterMapWithId p (IdMap m) + = IdMap (IntMap.filterWithKey (\i x -> p (idFromInt i) x) m) + +findMap :: Id -> IdMap a -> a +findMap x = fromMaybe (error msg) . lookupMap x + where + msg = "IdMap.findMap: unknown identifier " ++ show x + +-- sort is needed to not rely on an id's index +listFromMap :: IdMap a -> [(Id,a)] +listFromMap (IdMap idmap) + = sortBy (\x y -> fst x `compare` fst y) + $ map (first idFromInt) (IntMap.toList idmap) + +mapFromList :: [(Id,a)] -> IdMap a +mapFromList = IdMap . IntMap.fromList . map (first intFromId) + +diffMap :: IdMap a -> IdMap a -> IdMap a +diffMap (IdMap map1) (IdMap map2) + = IdMap (IntMap.difference map1 map2) + +unionMap :: IdMap a -> IdMap a -> IdMap a +unionMap (IdMap map1) (IdMap map2) + = IdMap (IntMap.unionWith err map1 map2) + where + err _ _ = error "IdMap.unionMap: duplicate identifiers" + +unionMapWith :: (a->a->a) -> IdMap a -> IdMap a -> IdMap a +unionMapWith f (IdMap map1) (IdMap map2) + = IdMap (IntMap.unionWith f map1 map2) + +unionlMap :: IdMap a -> IdMap a -> IdMap a +unionlMap (IdMap map1) (IdMap map2) = IdMap (map1 `IntMap.union` map2) + +unionMaps :: [IdMap a] -> IdMap a +unionMaps = foldr unionMap emptyMap + +foldMapWithId :: (Id -> a -> b -> b) -> b -> IdMap a -> b +foldMapWithId f z (IdMap m) = IntMap.foldWithKey (f . idFromInt) z m + +foldMap :: (a -> b -> b) -> b -> IdMap a -> b +foldMap f z (IdMap m) = IntMap.fold f z m + +sizeMap :: IdMap a -> Int +sizeMap (IdMap m) = IntMap.size m diff --git a/Lvm/Common/IdSet.hs b/Lvm/Common/IdSet.hs new file mode 100644 --- /dev/null +++ b/Lvm/Common/IdSet.hs @@ -0,0 +1,69 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: IdSet.hs 291 2012-11-08 11:27:33Z heere112 $ + +-- this module is exotic, only used by the core compiler +-- but it works with any IdMap +module Lvm.Common.IdSet + ( IdSet, Id + , emptySet, singleSet, elemSet, filterSet, foldSet + , insertSet, deleteSet, unionSet, unionSets, diffSet + , listFromSet, setFromList, sizeSet, isEmptySet + ) where + +import Data.IntSet (IntSet) +import Data.List (sort) +import Lvm.Common.Id +import qualified Data.IntSet as IntSet + +---------------------------------------------------------------- +-- IdSet +---------------------------------------------------------------- + +newtype IdSet = IdSet IntSet + +emptySet :: IdSet +emptySet = IdSet IntSet.empty + +singleSet :: Id -> IdSet +singleSet = IdSet . IntSet.singleton . intFromId + +elemSet :: Id -> IdSet -> Bool +elemSet x (IdSet s) = IntSet.member (intFromId x) s + +filterSet :: (Id -> Bool) -> IdSet -> IdSet +filterSet p (IdSet s) = IdSet (IntSet.filter (p . idFromInt) s) + +foldSet :: (Id -> a -> a) -> a -> IdSet -> a +foldSet f a (IdSet s) = IntSet.fold (f . idFromInt) a s + +insertSet :: Id -> IdSet -> IdSet +insertSet x (IdSet s) = IdSet (IntSet.insert (intFromId x) s) + +deleteSet :: Id -> IdSet -> IdSet +deleteSet x (IdSet s) = IdSet (IntSet.delete (intFromId x) s) + +unionSet :: IdSet -> IdSet -> IdSet +unionSet (IdSet s1) (IdSet s2) = IdSet (s1 `IntSet.union` s2) + +unionSets :: [IdSet] -> IdSet +unionSets xs = IdSet (IntSet.unions [ s | IdSet s <- xs ]) + +diffSet :: IdSet -> IdSet -> IdSet +diffSet (IdSet s1) (IdSet s2) = IdSet (IntSet.difference s1 s2) + +-- sort is needed to not rely on an id's index +listFromSet :: IdSet -> [Id] +listFromSet (IdSet s) = sort [ idFromInt n | n <- IntSet.elems s ] + +setFromList :: [Id] -> IdSet +setFromList = foldr insertSet emptySet + +sizeSet :: IdSet -> Int +sizeSet (IdSet s) = IntSet.size s + +isEmptySet :: IdSet -> Bool +isEmptySet (IdSet s) = IntSet.null s diff --git a/Lvm/Core/Expr.hs b/Lvm/Core/Expr.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Expr.hs @@ -0,0 +1,130 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Expr.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.Expr + ( CoreModule, CoreDecl, Expr(..), Binds(..), Bind(..) + , Alts, Alt(..), Pat(..), Literal(..), Con(..) + ) where + +import Lvm.Common.Byte +import Lvm.Common.Id +import Lvm.Core.Module +import Lvm.Core.PrettyId +import Text.PrettyPrint.Leijen + +---------------------------------------------------------------- +-- Modules +---------------------------------------------------------------- +type CoreModule = Module Expr +type CoreDecl = Decl Expr + +---------------------------------------------------------------- +-- Core expressions: +---------------------------------------------------------------- +data Expr = Let !Binds Expr + | Match !Id Alts + | Ap Expr Expr + | Lam !Id Expr + | Con !(Con Expr) + | Var !Id + | Lit !Literal + +data Binds = Rec ![Bind] + | Strict !Bind + | NonRec !Bind + +data Bind = Bind !Id Expr + +type Alts = [Alt] +data Alt = Alt !Pat Expr + +data Pat = PatCon !(Con Tag) ![Id] + | PatLit !Literal + | PatDefault + +data Literal = LitInt !Int + | LitDouble !Double + | LitBytes !Bytes + +data Con tag = ConId !Id + | ConTag tag !Arity + +---------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------- + +instance Pretty Expr where + pretty = ppExpr 0 + +ppExpr :: Int -> Expr -> Doc +ppExpr p expr + = case expr of + -- (Let (Strict (Bind id1 expr)) (Match id2 alts)) | id1 == id2 + -- -> prec 0 $ hang 2 (text "case" <+> ppExpr 0 expr <+> text "of" <+> ppId id1 <$> ppAlts alts) + Match x as -> prec 0 $ align (text "match" <+> ppVarId x <+> text "with" <+> text "{" <$> indent 2 (pretty as) + <+> text "}") + Let bs x -> prec 0 $ align (ppLetBinds bs (text "in" <+> ppExpr 0 x)) + Lam x e -> prec 0 $ text "\\" <> ppVarId x <+> ppLams "->" () e + Ap e1 e2 -> prec 9 $ ppExpr 9 e1 <+> ppExpr 10 e2 + Var x -> ppVarId x + Con con -> pretty con + Lit lit -> pretty lit + where + prec p' | p' >= p = id + | otherwise = parens + +instance Pretty a => Pretty (Con a) where + pretty con = + case con of + ConId x -> ppConId x + ConTag tag arity -> parens (char '@' <> pretty tag <> comma <> pretty arity) + +---------------------------------------------------------------- +-- +---------------------------------------------------------------- + +ppLams :: String -> (Doc -> Doc -> Doc) -> Expr -> Doc +ppLams arrow next expr + = case expr of + Lam x e -> ppVarId x <+> ppLams arrow next e + _ -> text arrow `next` ppExpr 0 expr + +ppLetBinds :: Binds -> Doc -> Doc +ppLetBinds binds doc + = case binds of + NonRec bind -> nest 4 (text "let" <+> pretty bind) <$> doc + Strict bind -> nest 5 (text "let!" <+> pretty bind) <$> doc + -- Rec recs -> nest 8 (text "let rec" <+> pretty recs) <$> doc + Rec recs -> nest 4 (text "let" <+> pretty recs) <$> doc -- let rec not parsable + +instance Pretty Bind where + pretty (Bind x expr) = + nest 2 (ppId x <+> ppLams "=" () expr <> semi) + prettyList = vcat . map pretty + +instance Pretty Alt where + pretty (Alt pat expr) = + nest 4 (pretty pat <+> text "->" ppExpr 0 expr <> semi) + prettyList = vcat . map pretty + +---------------------------------------------------------------- +-- +---------------------------------------------------------------- + +instance Pretty Pat where + pretty pat = + case pat of + PatCon con ids -> hsep (pretty con : map ppVarId ids) + PatLit lit -> pretty lit + PatDefault -> text "_" + +instance Pretty Literal where + pretty lit = + case lit of + LitInt i -> pretty i + LitDouble d -> pretty d + LitBytes s -> text (show (stringFromBytes s)) diff --git a/Lvm/Core/FreeVar.hs b/Lvm/Core/FreeVar.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/FreeVar.hs @@ -0,0 +1,65 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: FreeVar.hs 291 2012-11-08 11:27:33Z heere112 $ +---------------------------------------------------------------- +-- Calculate free variables +---------------------------------------------------------------- +module Lvm.Core.FreeVar (FreeVar(..), Binder(..)) where + +import Lvm.Common.IdSet +import Lvm.Core.Expr + +class FreeVar a where + freeVar :: a -> IdSet + +instance FreeVar a => FreeVar [a] where + freeVar = unionSets . map freeVar + +instance FreeVar Expr where + freeVar expr = + case expr of + Let bs e -> freeVar bs `unionSet` (freeVar e `diffSet` binder bs) + Match x e -> insertSet x (freeVar e) + Ap e1 e2 -> freeVar e1 `unionSet` freeVar e2 + Lam x e -> deleteSet x (freeVar e) + Con c -> freeVar c + Var x -> singleSet x + Lit _ -> emptySet + +instance FreeVar Alt where + freeVar (Alt p e) = freeVar e `diffSet` binder p + +instance FreeVar Binds where + freeVar binds = + case binds of + Rec bs -> freeVar bs `diffSet` binder bs + NonRec b -> freeVar b + Strict b -> freeVar b + +instance FreeVar Bind where + freeVar (Bind _ e) = freeVar e -- non-recursive binder! + +instance FreeVar a => FreeVar (Con a) where + freeVar (ConTag a _) = freeVar a + freeVar (ConId _) = emptySet + +class Binder a where + binder :: a -> IdSet + +instance Binder a => Binder [a] where + binder = unionSets . map binder + +instance Binder Pat where + binder (PatCon _ xs) = setFromList xs + binder _ = emptySet + +instance Binder Bind where + binder (Bind x _) = singleSet x + +instance Binder Binds where + binder (Rec bs) = binder bs + binder (NonRec b) = binder b + binder (Strict b) = binder b diff --git a/Lvm/Core/LetSort.hs b/Lvm/Core/LetSort.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/LetSort.hs @@ -0,0 +1,87 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: LetSort.hs 291 2012-11-08 11:27:33Z heere112 $ + +---------------------------------------------------------------- +-- Determine which bindings are really recursive and which are not. +-- maintains free variable information & normalised structure +---------------------------------------------------------------- +module Lvm.Core.LetSort (coreLetSort) where + +import Data.Graph hiding (topSort) +import Data.Tree +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.FreeVar +import Lvm.Core.Utils +import Data.Maybe +import Control.Arrow (second) + +---------------------------------------------------------------- +-- coreLetSort +-- pre: [coreFreeVar] all let bindings are annotated with their free variables +-- +-- transform a @Rec@ bindings into the smallest @NonRec@ and @Rec@ bindings. +---------------------------------------------------------------- +coreLetSort :: CoreModule -> CoreModule +coreLetSort = fmap lsExpr + +lsExpr :: Expr -> Expr +lsExpr expr + = case expr of + Let (Strict (Bind x rhs)) e + -> Let (Strict (Bind x (lsExpr rhs))) (lsExpr e) + Let binds e + -> let bindss = sortBinds binds + in foldr Let (lsExpr e) bindss + Match x alts + -> Match x (lsAlts alts) + Lam x e + -> Lam x (lsExpr e) + Ap e1 e2 + -> Ap (lsExpr e1) (lsExpr e2) + Con (ConTag tag arity) + -> Con (ConTag (lsExpr tag) arity) + _ + -> expr + +lsAlts :: Alts -> Alts +lsAlts = mapAlts (\pat -> Alt pat . lsExpr) + +---------------------------------------------------------------- +-- topological sort let bindings +---------------------------------------------------------------- +sortBinds :: Binds -> [Binds] +sortBinds (Rec bindsrec) + = let binds = map (\(Bind x rhs) -> (x,rhs)) bindsrec + names = zip (map fst binds) [0..] + es = concatMap (depends names) binds + sorted = topSort (length names-1) es + binds' = map (map (binds!!)) sorted + binds'' = map (map (second lsExpr)) binds' + in map toBinding binds'' -- foldr sortLets (lsExpr expr) binds'' +sortBinds binds + = [mapBinds (\x expr -> Bind x (lsExpr expr)) binds] + +-- topological sort +topSort :: Vertex -> [Edge] -> [[Vertex]] +topSort n = map flatten . scc . buildG (0, n) + +toBinding :: [(Id, Expr)] -> Binds +toBinding [(x,rhs)] + | not (elemSet x (freeVar rhs)) = NonRec (Bind x rhs) +toBinding binds + = Rec (map (uncurry Bind) binds) + +depends :: [(Id,Vertex)] -> (Id,Expr) -> [(Vertex,Vertex)] +depends names (v,expr) + = foldSet depend [] (freeVar expr) + where + index = fromMaybe (error msg) (lookup v names) + msg = "CoreLetSort.depends: id not in let group??" + depend x ds = case lookup x names of + Just i -> (index,i):ds + Nothing -> ds diff --git a/Lvm/Core/Lift.hs b/Lvm/Core/Lift.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Lift.hs @@ -0,0 +1,166 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Lift.hs 291 2012-11-08 11:27:33Z heere112 $ + +---------------------------------------------------------------- +-- Do "johnson" style lambda lifting +-- After this pass, each binding has either no free variables or no arguments. +-- maintains free variable information & normalised structure +---------------------------------------------------------------- +module Lvm.Core.Lift (coreLift) where + +import Data.List +import Data.Maybe +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.FreeVar +import Lvm.Core.Utils + +---------------------------------------------------------------- +-- The environment maps variables to variables that should +-- be supplied as arguments at each call site +---------------------------------------------------------------- +data Env = Env IdSet (IdMap [Id]) -- primitives && the free variables to be passed as arguments + +elemFree :: Env -> Id -> Bool +elemFree (Env _ env) x + = elemMap x env + +lookupFree :: Env -> Id -> [Id] +lookupFree (Env _ env) x + = fromMaybe [] (lookupMap x env) + +isPrimitive :: Env -> Id -> Bool +isPrimitive (Env prim _) = (`elemSet` prim) + +extendFree :: Env -> Id -> [Id] -> Env +extendFree (Env prim env) x fv + = Env prim (extendMap x fv env) + +---------------------------------------------------------------- +-- coreLift +-- pre: [coreFreeVar] each binding is annotated with free variables +-- [coreNoShadow] there is no shadowing +---------------------------------------------------------------- +coreLift :: CoreModule -> CoreModule +coreLift m + = fmap (liftExpr globals (Env primitives emptyMap)) m + where + primitives = externNames m + globals = globalNames m + +liftExpr :: IdSet -> Env -> Expr -> Expr +liftExpr globals env expr + = case expr of + Let binds e + -> let (binds',env') = liftBinds globals env binds + in Let binds' (liftExpr globals env' e) + Match x alts + -> Match x (liftAlts globals env alts) + Lam x e + -> Lam x (liftExpr globals env e) + Ap expr1 expr2 + -> Ap (liftExpr globals env expr1) (liftExpr globals env expr2) + Var x + -> foldl' (\e v -> Ap e (Var v)) expr (lookupFree env x) + Con (ConTag tag arity) + -> Con (ConTag (liftExpr globals env tag) arity) + _ + -> expr + +liftAlts :: IdSet -> Env -> Alts -> Alts +liftAlts globals env = mapAlts (\pat expr -> Alt pat (liftExpr globals env expr)) + +---------------------------------------------------------------- +-- Lift binding groups +---------------------------------------------------------------- + +liftBinds :: IdSet -> Env -> Binds -> (Binds, Env) +liftBinds globals env binds + = case binds of + NonRec bind -> let ([bind'],env') = liftBindsRec globals env [bind] + in (NonRec bind',env') + Rec recs -> let (recs',env') = liftBindsRec globals env recs + in (Rec recs',env') + Strict (Bind x rhs) + -> (Strict (Bind x (liftExpr globals env rhs)),env) + +freeVar2 :: IdSet -> Expr -> IdSet +freeVar2 globals = (`diffSet` globals) . freeVar + +liftBindsRec :: IdSet -> Env -> [Bind] -> ([Bind],Env) +liftBindsRec globals env recs + = let (ids,exprs) = unzipBinds recs + -- calculate the mutual free variables + fvmap = fixMutual (zip ids (map (liftedFreeVar env . freeVar2 globals) exprs)) + -- note these recursive equations :-) + fvs = map (removeLifted env' . listFromSet . snd) fvmap + env' = foldl insertLifted env (zip recs fvs) + + -- put the computed free variables back into the bindings as lambdas + recs' = zipWith (addLambdas env) fvs (zipWith Bind ids (map (liftExpr globals env') exprs)) + in (recs', env') + +addLambdas :: Env -> [Id] -> Bind -> Bind +addLambdas env fv bind@(Bind x expr) + | isAtomExpr env expr = bind + | otherwise = Bind x (foldr Lam expr fv) + +insertLifted :: Env -> (Bind, [Id]) -> Env +insertLifted env (Bind x expr,fv) + = if isAtomExpr env expr -- || isValueExpr expr) + then env + else extendFree env x fv + +removeLifted :: Env -> [Id] -> [Id] +removeLifted env = filter (not . elemFree env) + + +fixMutual :: [(Id,IdSet)] -> [(Id,IdSet)] +fixMutual fvmap + = let fvmap' = map addMutual fvmap + in if size fvmap' == size fvmap + then fvmap + else fixMutual fvmap' + where + addMutual (x,fv) + = (x, foldSet addLocalFree fv fv) + + addLocalFree x fv0 + = case lookup x fvmap of + Just fv1 -> unionSet fv0 fv1 + Nothing -> fv0 + + size xs + = sum (map (sizeSet . snd) xs) + + +liftedFreeVar :: Env -> IdSet -> IdSet +liftedFreeVar env fv + = unionSet fv (setFromList (concatMap (lookupFree env) (listFromSet fv))) + +---------------------------------------------------------------- +-- is an expression atomic: i.e. can we generate code inplace +---------------------------------------------------------------- + +isAtomExpr :: Env -> Expr -> Bool +isAtomExpr env expr + = case expr of + Ap e1 e2 -> isAtomExpr env e1 && isAtomExpr env e2 + Var x -> not (isPrimitive env x) + Con _ -> True + Lit _ -> True + Let binds e -> isAtomBinds env binds && isAtomExpr env e + _ -> False + +isAtomBinds :: Env -> Binds -> Bool +isAtomBinds env binds + = case binds of + Strict _ -> False + NonRec (Bind _ expr) -> isAtomExpr env expr + Rec bindings -> all (isAtomExpr env) (snd (unzipBinds bindings)) diff --git a/Lvm/Core/Main.hs b/Lvm/Core/Main.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Main.hs @@ -0,0 +1,181 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Main.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Main (main) where + +import Control.Monad +import Lvm.Common.Id +import Lvm.Path +import System.Console.GetOpt +import System.Environment +import System.Exit +import Text.PrettyPrint.Leijen + +import Lvm.Asm.Inline (asmInline) -- optimize Asm (ie. local inlining) +import Lvm.Asm.ToLvm (asmToLvm) -- translate Asm to Lvm instructions +import Lvm.Core.Module (modulePublic) -- imports +import Lvm.Core.Parsing.Layout (layout) -- apply layout rule +import Lvm.Core.Parsing.Lexer (lexer) -- lexical tokens +import Lvm.Core.Parsing.Parser (parseModuleExport) -- parse text into Core +import Lvm.Core.RemoveDead (coreRemoveDead) -- remove dead declarations +import Lvm.Core.ToAsm (coreToAsm) -- enriched lambda expressions (Core) to Asm +import Lvm.Import (lvmImport) -- resolve import declarations +import Lvm.Write (lvmWriteFile) -- write a binary Lvm file + +---------------------------------------------------------------- +-- +---------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + case getOpt Permute options args of + (flags, files, errs) + | Help `elem` flags -> do + putStrLn (usageInfo header options) + exitSuccess + | Version `elem` flags -> do + putStrLn ("coreasm, " ++ versionText) + exitSuccess + | null errs && not (null files) -> do + mapM_ (compile flags) files + exitSuccess + | otherwise -> do + putStrLn $ concat errs ++ + "Usage: For basic information, try the --help option." + exitFailure + +versionText :: String +versionText = "version 1.7" -- $Id: Main.hs 291 2012-11-08 11:27:33Z heere112 $" + +header :: String +header = + "coreasm: The Core Assembler for the Lazy Virtual Machine\n" ++ + "Copyright 2001, Daan Leijen\n" ++ + "\nUsage: coreasm [OPTION] \n" ++ + "\nOptions:" + +data Flag = Help | Version | Verbosity Verbosity | Dump Dump (Maybe String) + deriving Eq + +data Verbosity = Silent | Normal | Verbose + deriving (Eq, Ord) + +data Dump = DumpTokens | DumpCore | DumpCoreOpt | DumpAsm + | DumpAsmOpt | DumpInstr + deriving Eq + +getVerbosity :: [Flag] -> Verbosity +getVerbosity flags = + case [ a | Verbosity a <- flags ] of + [] -> Normal + xs -> minimum xs + +flagVerbose, flagSilent :: Flag +flagVerbose = Verbosity Verbose +flagSilent = Verbosity Silent + +options :: [OptDescr Flag] +options = + [ simple [] "version" Version "show version number" + , simple "?" "help" Help "show options" + , simple [] "verbose" flagVerbose "verbose output" + , simple [] "silent" flagSilent "no output" + , dump "dump-tokens" DumpTokens "pretty print tokens" + , dump "dump-core" DumpCore "pretty print core" + , dump "dump-core-opt" DumpCoreOpt "pretty print core (optimized)" + , dump "dump-asm" DumpAsm "pretty print assembler" + , dump "dump-asm-opt" DumpAsmOpt "pretty print assembler (optimized)" + , dump "dump-instr" DumpInstr "pretty print instructions" + ] + where + simple xs long = Option xs [long] . NoArg + dump long d = Option [] [long] (OptArg (Dump d) "file") + +findModule :: [String] -> Id -> IO String +findModule paths = searchPath paths ".lvm" . stringFromId + +findSrc :: [String] -> String -> IO String +findSrc paths = searchPath paths ".core" + +compile :: [Flag] -> FilePath -> IO () +compile flags src = do + -- searching + message flags $ "Compiling " ++ showFile src + lvmPath <- getLvmPath + let path = "." : lvmPath + source <- findSrc path src + verbose $ "Source file: " ++ showFile source + + -- lexing + verbose "Lexing" + input <- readFile source + let tokens = layout (lexer (1,1) input) + dumpWith DumpTokens flags "Tokens" tokens + + -- parsing + verbose "Parsing" + (m, implExps, es) <- parseModuleExport source tokens + + -- resolving + verbose "Resolving imports" + chasedMod <- lvmImport (findModule path) m + let publicmod = modulePublic implExps es chasedMod + dumpWith DumpCore flags "Core" publicmod + + -- compiling + verbose "Remove dead declarations" + let coremod = coreRemoveDead publicmod + dumpWith DumpCoreOpt flags "Core (dead declarations removed)" coremod + + verbose "Generating code" + nameSupply <- newNameSupply + + let asmmod = coreToAsm nameSupply coremod + dumpWith DumpAsm flags "Assembler" asmmod + + let asmopt = asmInline asmmod + dumpWith DumpAsmOpt flags "Assembler (optimized)" asmopt + + let lvmmod = asmToLvm asmopt + dumpWith DumpInstr flags "Instructions" lvmmod + + -- writing + let target = reverse (dropWhile (/='.') (reverse source)) ++ "lvm" + message flags $ "Writing " ++ showFile target + lvmWriteFile target lvmmod + + where + verbose :: Pretty a => a -> IO () + verbose = messageFor Verbose flags + +--------------------------------------------------------------------- +-- Messages + +message :: Pretty a => [Flag] -> a -> IO () +message = messageFor Normal + +messageFor :: Pretty a => Verbosity -> [Flag] -> a -> IO () +messageFor a flags = + when (getVerbosity flags >= a) . messageDoc + +messageDoc :: Pretty a => a -> IO () +messageDoc = print . pretty + +dumpWith :: Pretty a => Dump -> [Flag] -> String -> a -> IO () +dumpWith dump flags s a = + case [ mf | Dump d mf <- flags, d == dump ] of + Just file:_ -> do message flags ("Writing " ++ file) + writeFile file (show (pretty a)) + Nothing:_ -> messageDoc nice + [] -> return () + where + nice = vsep [hline, pretty ("-- " ++ s), empty, pretty a, hline] + hline = pretty (replicate 40 '-') + +showFile :: String -> String +showFile = map (\c -> if c == '\\' then '/' else c) diff --git a/Lvm/Core/Module.hs b/Lvm/Core/Module.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Module.hs @@ -0,0 +1,429 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Module.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.Module + ( Module(..), Decl(..), Custom(..), DeclKind(..) + , Arity, Tag, Access(..), ExternName(..), CallConv(..), LinkConv(..) + , globalNames, externNames, filterPublic, mapDecls + , customDeclKind, customData, customTypeDecl, modulePublic + , declKindFromDecl, shallowKindFromDecl, makeDeclKind + , isDeclValue, isDeclAbstract, isDeclCon, isDeclExtern + , isDeclImport, isDeclGlobal + , public, private + ) where + +import Lvm.Common.Byte +import Lvm.Common.Id +import Lvm.Common.IdSet +import Lvm.Core.PrettyId +import Lvm.Instr.Data +import Text.PrettyPrint.Leijen + +{--------------------------------------------------------------- + A general LVM module structure parameterised by the + type of values (Core expression, Asm expression or [Instr]) +---------------------------------------------------------------} +data Module v + = Module{ moduleName :: Id + , moduleMajorVer :: !Int + , moduleMinorVer :: !Int + , moduleDecls :: ![Decl v] + } + + +data Decl v + = DeclValue { declName :: Id, declAccess :: !Access, valueEnc :: Maybe Id, valueValue :: v, declCustoms :: ![Custom] } + | DeclAbstract { declName :: Id, declAccess :: !Access, declArity :: !Arity, declCustoms :: ![Custom] } + | DeclCon { declName :: Id, declAccess :: !Access, declArity :: !Arity, conTag :: !Tag, declCustoms :: [Custom] } + | DeclExtern { declName :: Id, declAccess :: !Access, declArity :: !Arity + , externType :: !String, externLink :: !LinkConv, externCall :: !CallConv + , externLib :: !String, externName :: !ExternName, declCustoms :: ![Custom] } + | DeclCustom { declName :: Id, declAccess :: !Access, declKind :: !DeclKind, declCustoms :: ![Custom] } + + | DeclImport { declName :: Id, declAccess :: !Access, declCustoms :: ![Custom] } + +data Custom + = CustomInt !Int + | CustomBytes !Bytes + | CustomName Id + | CustomLink Id !DeclKind + | CustomDecl !DeclKind ![Custom] + | CustomNothing + +data DeclKind + = DeclKindName + | DeclKindKind + | DeclKindBytes + | DeclKindCode + | DeclKindValue + | DeclKindCon + | DeclKindImport + | DeclKindModule + | DeclKindExtern + | DeclKindExternType + | DeclKindCustom !Id + deriving (Eq,Show) + +data Access + = Defined { accessPublic :: !Bool } + | Imported { accessPublic :: !Bool, importModule :: Id, importName :: Id, importKind :: !DeclKind + , importMajorVer :: !Int, importMinorVer :: !Int } + +public, private :: Access +public = Defined True +private = Defined False + +-- externals +data ExternName = Plain !String + | Decorate !String + | Ordinal !Int + deriving Show + +data CallConv = CallC | CallStd | CallInstr + deriving (Show, Eq, Enum) + +data LinkConv = LinkStatic | LinkDynamic | LinkRuntime + deriving (Show, Eq, Enum) + + +instance Ord DeclKind where + compare k1 k2 + = case (k1,k2) of + (DeclKindCustom id1,DeclKindCustom id2) -> compare id1 id2 + (DeclKindCustom _,_) -> GT + (_,DeclKindCustom _) -> LT + _ -> compare (fromEnum k1) (fromEnum k2) + + + +instance Enum DeclKind where + toEnum i + = case i of + 0 -> DeclKindName + 1 -> DeclKindKind + 2 -> DeclKindBytes + 3 -> DeclKindCode + 4 -> DeclKindValue + 5 -> DeclKindCon + 6 -> DeclKindImport + 7 -> DeclKindModule + 8 -> DeclKindExtern + 9 -> DeclKindExternType + _ -> error ("Module.DeclKind.toEnum: unknown kind (" ++ show i ++ ")") + + fromEnum kind + = case kind of + DeclKindName -> 0 + DeclKindKind -> 1 + DeclKindBytes -> 2 + DeclKindCode -> 3 + DeclKindValue -> 4 + DeclKindCon -> 5 + DeclKindImport -> 6 + DeclKindModule -> 7 + DeclKindExtern -> 8 + DeclKindExternType-> 9 +-- DeclKindCustom i -> i + _ -> error "Module.DeclKind.fromEnum: unknown kind" + +customDeclKind :: String -> DeclKind +customDeclKind = DeclKindCustom . idFromString + +customData, customTypeDecl :: DeclKind +customData = customDeclKind "data" +customTypeDecl = customDeclKind "typedecl" + +declKindFromDecl :: Decl a -> DeclKind +declKindFromDecl decl + = case decl of + DeclValue{} -> DeclKindValue + DeclAbstract{} -> DeclKindValue + DeclCon{} -> DeclKindCon + DeclExtern{} -> DeclKindExtern + DeclCustom{} -> declKind decl + DeclImport{} -> importKind (declAccess decl) + -- _ -> error "Module.kindFromDecl: unknown declaration" + +shallowKindFromDecl :: Decl a -> DeclKind +shallowKindFromDecl decl + = case decl of + DeclValue{} -> DeclKindValue + DeclAbstract{} -> DeclKindValue + DeclCon{} -> DeclKindCon + DeclExtern{} -> DeclKindExtern + DeclCustom{} -> declKind decl + DeclImport{} -> DeclKindImport + -- _ -> error "Module.shallowKindFromDecl: unknown declaration" + +modulePublic :: Bool -> (IdSet,IdSet,IdSet,IdSet,IdSet) -> Module v -> Module v +modulePublic implicit (exports,exportCons,exportData,exportDataCon,exportMods) m + = m { moduleDecls = map setPublic (moduleDecls m) } + where + setPublic decl | declPublic decl = decl{ declAccess = (declAccess decl){ accessPublic = True } } + | otherwise = decl + + isExported decl elemIdSet = + let access = declAccess decl in + if implicit then + case decl of + DeclImport{} -> False + _ -> + case access of + Imported{} -> False + Defined{} -> accessPublic access + else + case access of + Imported{ importModule = x } + | elemSet x exportMods -> True + | otherwise -> elemIdSet + Defined{} + | elemSet (moduleName m) exportMods -> True + | otherwise -> elemIdSet + + declPublic decl = + let name = declName decl + in + case decl of + DeclValue{} -> isExported decl (elemSet name exports) + DeclAbstract{} -> isExported decl (elemSet name exports) + DeclExtern{} -> isExported decl (elemSet name exports) + DeclCon{} -> isExported decl + ( elemSet name exportCons + || elemSet (conTypeName decl) exportDataCon + ) + DeclCustom{} -> isExported decl + ( declKind decl `elem` [customData, customTypeDecl] + && elemSet name exportData + ) + DeclImport{} -> not implicit && case importKind (declAccess decl) of + DeclKindValue -> isExported decl (elemSet name exports) + DeclKindExtern -> isExported decl (elemSet name exports) + DeclKindCon -> isExported decl (elemSet name exportCons) + DeclKindModule -> isExported decl (elemSet name exportMods) + dk@(DeclKindCustom _) + | dk `elem` [customData, customTypeDecl] -> + isExported decl (elemSet name exportData) + _ -> False + + conTypeName (DeclCon{declCustoms=(_:CustomLink x _:_)}) = x + conTypeName _ = dummyId + +---------------------------------------------------------------- +-- Functors +---------------------------------------------------------------- + +instance Functor Module where + fmap f m = m { moduleDecls = map (fmap f) (moduleDecls m) } + +instance Functor Decl where + fmap f decl = + case decl of + DeclValue x ac m v cs -> + DeclValue x ac m (f v) cs + DeclAbstract x ac ar cs -> + DeclAbstract x ac ar cs + DeclCon x ac ar t cs -> + DeclCon x ac ar t cs + DeclExtern x ac ar et el ec elib en cs -> + DeclExtern x ac ar et el ec elib en cs + DeclCustom x ac k cs -> + DeclCustom x ac k cs + DeclImport x ac cs -> + DeclImport x ac cs + +---------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------- + +instance Pretty a => Pretty (Module a) where + pretty (Module name _ _ decls) = + text "module" <+> ppConId name <+> text "where" + <$> vcat (map (\decl -> pretty decl <> semi <> line) decls) + <$> empty + +instance Pretty a => Pretty (Decl a) where + pretty decl = nest 2 $ + case decl of + DeclValue{} -> ppVarId (declName decl) <+> ppAttrs decl + <$> text "=" <+> pretty (valueValue decl) + DeclCon{} -> case declAccess decl of + imp@Imported{} -> + text "abstract" <+> ppConId (declName decl) + <+> ppAttrs decl + <$> text "=" <+> ppQualCon (importModule imp) (importName imp) + <+> parens (char '@' <> pretty (conTag decl) <> + comma <> pretty (declArity decl)) + + _ -> text "con" <+> ppConId (declName decl) <+> ppAttrs decl + <$> text "=" <+> parens (char '@' <> pretty (conTag decl) <> + comma <> pretty (declArity decl)) + DeclCustom{} -> text "custom" <+> pretty (declKind decl) <+> ppId (declName decl) <+> ppAttrs decl + DeclExtern{} -> text "extern" + <> pretty (externLink decl) <> pretty (externCall decl) + <+> ppVarId (declName decl) -- <+> ppAttrs decl + <+> ppExternName (externLib decl) (externName decl) -- <+> pretty (declArity decl) + <+> ppExternType (externCall decl) (externType decl) + DeclAbstract{} -> text "abstract" <+> ppVarId (declName decl) <+> ppAttrs decl + <$> text "=" <+> ppImported (declAccess decl) <+> pretty (declArity decl) + DeclImport{} -> text "import" <+> pretty (importKind (declAccess decl)) + <+> ppId (declName decl) <+> ppNoImpAttrs decl + <$> text "=" <+> ppImported (declAccess decl) + +instance Pretty LinkConv where + pretty linkConv = + case linkConv of + LinkRuntime -> text " runtime" + LinkDynamic -> text " dynamic" + LinkStatic -> empty + +instance Pretty CallConv where + pretty callConv = + case callConv of + CallInstr -> text " instrcall" + CallStd -> text " stdcall" + CallC -> empty + +ppExternName :: String -> ExternName -> Doc +ppExternName libName extName + = case extName of + Plain name -> dquotes (ppQual name) + Decorate name -> text "decorate" <+> ppQual name + Ordinal i -> ppQual (show i) + where + ppQual name + | null libName = ppVarId (idFromString name) + | otherwise = ppQualId (idFromString libName) (idFromString name) + +ppExternType :: CallConv -> String -> Doc +ppExternType callConv tp + = text "::" <+> case callConv of + CallInstr -> pretty tp + _ -> ppString tp + +ppNoImpAttrs :: Decl a -> Doc +ppNoImpAttrs = ppAttrsEx True + +ppAttrs :: Decl a -> Doc +ppAttrs = ppAttrsEx False + +ppAttrsEx :: Bool -> Decl a -> Doc +ppAttrsEx hideImp decl + = if null (declCustoms decl) && not (accessPublic (declAccess decl)) + then empty + else text ":" <+> ppAccess (declAccess decl) + <+> (if not hideImp then ppImportAttr (declAccess decl) else empty) + <> pretty (declCustoms decl) + +ppAccess :: Access -> Doc +ppAccess acc + | accessPublic acc = text "public" + | otherwise = text "private" + +ppImportAttr :: Access -> Doc +ppImportAttr acc + = case acc of + Defined _ -> empty + Imported _ modid impid impkind _ _ + -> text "import" <+> pretty impkind <+> ppQualId modid impid <> space + +ppImported :: Access -> Doc +ppImported acc + = case acc of + Defined _ -> error "ModulePretty.ppImported: internal error: abstract or import value should always be imported!" + Imported _ modid impid _ _ _ + -> ppQualId modid impid + +instance Pretty Custom where + pretty custom = + case custom of + CustomInt i -> pretty i + CustomName x -> ppId x + CustomBytes bs -> dquotes (string (stringFromBytes bs)) + CustomLink x kind -> text "custom" <+> pretty kind <+> ppId x + CustomDecl kind cs -> text "custom" <+> pretty kind <+> pretty cs + CustomNothing -> text "nothing" + + prettyList customs + | null customs = empty + | otherwise = list (map pretty customs) + +instance Pretty DeclKind where + pretty kind = + case kind of + DeclKindCustom x -> ppId x +-- DeclKindName +-- DeclKindKind +-- DeclKindBytes +-- DeclKindCode + DeclKindValue -> ppId (idFromString "val") + DeclKindCon -> ppId (idFromString "con") + DeclKindImport -> ppId (idFromString "import") + DeclKindModule -> ppId (idFromString "module") + DeclKindExtern -> ppId (idFromString "extern") +-- DeclKindExternType + _ -> pretty (fromEnum kind) + +makeDeclKind :: Id -> DeclKind +makeDeclKind x = + case stringFromId x of + "val" -> DeclKindValue + "con" -> DeclKindCon + "import" -> DeclKindImport + "module" -> DeclKindModule + "extern" -> DeclKindExtern + _ -> DeclKindCustom x + +{--------------------------------------------------------------- + Utility functions +---------------------------------------------------------------} + +isDeclValue :: Decl a -> Bool +isDeclValue (DeclValue{}) = True +isDeclValue _ = False + +isDeclAbstract :: Decl a -> Bool +isDeclAbstract (DeclAbstract{}) = True +isDeclAbstract _ = False + +isDeclImport :: Decl a -> Bool +isDeclImport (DeclImport{}) = True +isDeclImport _ = False + +isDeclCon :: Decl a -> Bool +isDeclCon (DeclCon{}) = True +isDeclCon _ = False + +isDeclExtern :: Decl a -> Bool +isDeclExtern (DeclExtern{}) = True +isDeclExtern _ = False + +isDeclGlobal :: Decl a -> Bool +isDeclGlobal (DeclValue{}) = True +isDeclGlobal (DeclAbstract{}) = True +isDeclGlobal (DeclExtern{}) = True +isDeclGlobal _ = False + +-- hasDeclKind kind decl = (kind==declKindFromDecl decl) + +{--------------------------------------------------------------- + More Utility functions +---------------------------------------------------------------} +filterPublic :: Module v -> Module v +filterPublic m + = m { moduleDecls = [d | d <- moduleDecls m, accessPublic (declAccess d)] } + +globalNames :: Module v -> IdSet +globalNames m + = setFromList [declName d | d <- moduleDecls m, isDeclValue d || isDeclAbstract d || isDeclExtern d] + +externNames :: Module v -> IdSet +externNames m + = setFromList [declName d | d <- moduleDecls m, isDeclExtern d] + +mapDecls :: (Decl v -> Decl w) -> Module v -> Module w +mapDecls f m + = m { moduleDecls = map f (moduleDecls m) } diff --git a/Lvm/Core/NoShadow.hs b/Lvm/Core/NoShadow.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/NoShadow.hs @@ -0,0 +1,119 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: NoShadow.hs 291 2012-11-08 11:27:33Z heere112 $ + +---------------------------------------------------------------- +-- Make all local bindings locally unique. +-- and all local let-bindings globally unique. +-- +-- After this pass, no variables shadow each other and let-bound variables +-- are globally unique. +---------------------------------------------------------------- +module Lvm.Core.NoShadow (coreNoShadow, coreRename) where + +import Data.Maybe +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.Utils + +---------------------------------------------------------------- +-- Environment: name supply, id's in scope & renamed identifiers +---------------------------------------------------------------- +data Env = Env NameSupply IdSet (IdMap Id) + +renameBinders :: Env -> [Id] -> (Env, [Id]) +renameBinders env bs + = let (env',bs') = foldl (\(env1,ids) x1 -> renameBinder env1 x1 $ \env2 x2 -> (env2,x2:ids)) (env,[]) bs + in (env',reverse bs') + +renameLetBinder :: Env -> Id -> (Env -> Id -> a) -> a +renameLetBinder (Env supply inscope renaming) x cont + = let (x2,supply') = freshIdFromId x supply + inscope' = insertSet x inscope + renaming' = extendMap x x2 renaming + in cont (Env supply' inscope' renaming') x2 + +renameBinder :: Env -> Id -> (Env -> Id -> a) -> a +renameBinder env@(Env supply set m) x cont + | elemSet x set + = renameLetBinder env x cont + | otherwise + = cont (Env supply (insertSet x set) m) x + +renameVar :: Env -> Id -> Id +renameVar (Env _ _ m) x + = fromMaybe x (lookupMap x m) + +splitEnv :: Env -> (Env,Env) +splitEnv (Env supply set m) + = let (s0,s1) = splitNameSupply supply + in (Env s0 set m,Env s1 set m) + +splitEnvs :: Env -> [Env] +splitEnvs (Env supply set idmap) + = map (\s -> Env s set idmap) (splitNameSupplies supply) + + +---------------------------------------------------------------- +-- coreNoShadow: make all local variables locally unique +-- ie. no local variable shadows another variable +---------------------------------------------------------------- +coreNoShadow :: NameSupply -> CoreModule -> CoreModule +coreNoShadow = mapExprWithSupply (nsDeclExpr emptySet) + +coreRename :: NameSupply -> CoreModule -> CoreModule +coreRename supply m = mapExprWithSupply (nsDeclExpr (globalNames m)) supply m + +nsDeclExpr :: IdSet -> NameSupply -> Expr -> Expr +nsDeclExpr inscope supply = nsExpr (Env supply inscope emptyMap) + + +nsExpr :: Env -> Expr -> Expr +nsExpr env expr + = case expr of + Let binds e -> nsBinds env binds $ \env' binds' -> + Let binds' (nsExpr env' e) + Match x alts -> Match (renameVar env x) (nsAlts env alts) + Lam x e -> renameBinder env x $ \env2 x2 -> + Lam x2 (nsExpr env2 e) + Ap expr1 expr2 -> let (env1,env2) = splitEnv env + in Ap (nsExpr env1 expr1) (nsExpr env2 expr2) + Var x -> Var (renameVar env x) + Con (ConTag e a) -> Con (ConTag (nsExpr env e) a) + _ -> expr + +nsBinds :: Env -> Binds -> (Env -> Binds -> a) -> a +nsBinds env binds cont + = case binds of + Strict (Bind x rhs) -> nonrec Strict x rhs + NonRec (Bind x rhs) -> nonrec NonRec x rhs + Rec _ -> rec_ + where + nonrec make x1 rhs + = renameLetBinder env x1 $ \env' x2 -> + cont env' (make (Bind x2 (nsExpr env rhs))) + + rec_ + = let (binds',env') = mapAccumBinds (\env1 x1 rhs -> renameLetBinder env1 x1 $ \env2 x2 -> (Bind x2 rhs,env2)) + env binds + in cont env' (zipBindsWith (\env1 x1 rhs -> Bind x1 (nsExpr env1 rhs)) (splitEnvs env') binds') + +nsAlts :: Env -> Alts -> Alts +nsAlts = zipAltsWith nsAlt . splitEnvs + +nsAlt :: Env -> Pat -> Expr -> Alt +nsAlt env pat expr + = let (pat',env') = nsPat env pat + in Alt pat' (nsExpr env' expr) + +nsPat :: Env -> Pat -> (Pat, Env) +nsPat env pat + = case pat of + PatCon con ids -> let (env',ids') = renameBinders env ids + in (PatCon con ids',env') + other -> (other,env) diff --git a/Lvm/Core/Normalize.hs b/Lvm/Core/Normalize.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Normalize.hs @@ -0,0 +1,150 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Normalize.hs 291 2012-11-08 11:27:33Z heere112 $ + +---------------------------------------------------------------- +-- Normalises Core: +-- * no lambda's, except directly at let-bindings +-- * each Ap argument is atomic & not a call to an instruction or external function +-- * each Ap target is atomic +-- +-- an atomic expression is +-- * a Var +-- * a Lit +-- * a Con +-- * a normalised Ap +-- * a normalised Let(Rec) expression +-- +-- pre: [coreNoShadow, coreSaturate] +---------------------------------------------------------------- +module Lvm.Core.Normalize (coreNormalize) where + +import Lvm.Common.Id +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.Utils + +---------------------------------------------------------------- +-- Environment: the name supply +---------------------------------------------------------------- +data Env = Env NameSupply !IdSet {- instructions + externs -} + +uniqueId :: Env -> Id +uniqueId (Env supply _) = fst (freshId supply) + +splitEnv :: Env -> (Env, Env) +splitEnv (Env s d) + = let (s0,s1) = splitNameSupply s in (Env s0 d, Env s1 d) + +splitEnvs :: Env -> [Env] +splitEnvs (Env s d) = map (`Env` d) (splitNameSupplies s) + +isDirect :: Env -> Id -> Bool +isDirect (Env _ d) x = elemSet x d + +---------------------------------------------------------------- +-- coreNormalise +---------------------------------------------------------------- +coreNormalize :: NameSupply -> CoreModule -> CoreModule +coreNormalize supply m + = mapExprWithSupply (normDeclExpr primitives) supply m + where + primitives = externNames m + +normDeclExpr :: IdSet -> NameSupply -> Expr -> Expr +normDeclExpr directs supply = normBind (Env supply directs) + +---------------------------------------------------------------- +-- Expression & bindings +---------------------------------------------------------------- + +normExpr :: Env -> Expr -> Expr +normExpr env expr + = let (env1,env2) = splitEnv env + expr' = normBind env1 expr + in case expr' of + Lam _ _ -> let x = uniqueId env2 + in (Let (NonRec (Bind x expr')) (Var x)) + _ -> expr' + +-- can return lambda's on top +normBind :: Env -> Expr -> Expr +normBind env expr + = case expr of + Let binds e -> let (env1,env2) = splitEnv env + in Let (normBinds env1 binds) (normExpr env2 e) + Match x alts -> Match x (normAlts env alts) + Lam x e -> Lam x (normBind env e) + Ap _ _ -> normAtomExpr env expr + _ -> expr + +normBinds :: Env -> Binds -> Binds +normBinds + = zipBindsWith (\env x expr -> Bind x (normBind env expr)) . splitEnvs + +normAlts :: Env -> Alts -> Alts +normAlts + = zipAltsWith (\env pat expr -> Alt pat (normExpr env expr)) . splitEnvs + +normAtomExpr :: Env -> Expr -> Expr +normAtomExpr env expr + = let (atom,f) = normAtom env expr + in (f atom) + +-- returns an atomic expression + a function that adds the right bindings +normAtom :: Env -> Expr -> (Expr, Expr -> Expr) +normAtom env expr + = case expr of + Match _ _ -> freshBinding + Lam _ _ -> freshBinding + Let (Strict _) _ -> freshBinding + -- we could leave let bindings in place when they are fully + -- atomic but otherwise the bindings get messed up (shadow7.core). + -- we lift all bindings out and rely on asmInline to put them + -- back again if possible. + Let binds e -> let (env1,env2) = splitEnv env + (atom,f) = normAtom env1 e + -- (abinds,g) = normAtomBinds env2 binds + in (atom, Let (normBinds env2 binds) . f) + -- (abinds atom, f . g) + Ap e1 e2 -> let (env1,env2) = splitEnv env + (atom,f) = normAtom env1 e1 + (arg,g) = normArg env2 e2 + in (Ap atom arg, f . g) + _ -> (expr,id) + where + freshBinding = let (env1,env2) = splitEnv env + expr' = normBind env1 expr + x = uniqueId env2 + in (Var x, Let (NonRec (Bind x expr'))) + +-- normAtomBinds returns two functions: one that adds atomic +-- let bindings and one that adds non-atomic bindings +{- normAtomBinds :: Env -> Binds -> (Expr -> Expr, Expr -> Expr) +normAtomBinds env binds + = let (binds',(env',f)) = mapAccumBinds norm (env,id) binds + in (Let binds', f) + where + norm (env,f) id expr = let (env1,env2) = splitEnv env + (atom,g) = normAtom env1 expr + in (Bind id atom, (env2, f . g)) +-} +-- just as an atomic expression but binds 'direct' applications (ie. externs & instructions) +normArg :: Env -> Expr -> (Expr, Expr -> Expr) +normArg env expr + = let (env1,env2) = splitEnv env + (atom,f) = normAtom env1 expr + in if isDirectAp env atom + then let x = uniqueId env2 + in (Var x, f . Let (NonRec (Bind x atom))) + else (atom,f) + +isDirectAp :: Env -> Expr -> Bool +isDirectAp env expr + = case expr of + Ap e1 _ -> isDirectAp env e1 + Var x -> isDirect env x + _ -> False diff --git a/Lvm/Core/Parsing/Layout.hs b/Lvm/Core/Parsing/Layout.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Parsing/Layout.hs @@ -0,0 +1,108 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Lexer.hs 269 2012-08-31 15:16:49Z bastiaan $ + +module Lvm.Core.Parsing.Layout (layout) where + +import Lvm.Core.Parsing.Token + +----------------------------------------------------------- +-- The layout rule +----------------------------------------------------------- + +layout :: [Token] -> [Token] +layout = doubleSemi . lay [] . addLayout + + +data Layout = CtxLay Int + | CtxLet Int + | CtxBrace + | Indent Int + deriving (Eq,Show) + +type LayoutToken = Either (Pos, Layout) Token + +getPos :: LayoutToken -> Pos +getPos = either fst fst + +addLayout :: [Token] -> [LayoutToken] +addLayout ts = + case ts of + (pos,LexMODULE):_ -> addLay pos rest + (pos,LexLBRACE):_ -> addLay pos rest + (pos,_):_ -> Left (pos, CtxLay (snd pos)) : addLay pos rest + [] -> [] + where + rest = map Right ts + +addLay :: Pos -> [LayoutToken] -> [LayoutToken] +addLay _ [] = [] +addLay (l, _) (t:ts) = + case t of + Left (pos@(ln, col), _) + | ln > l -> Left (pos, Indent col) : rest + | otherwise -> rest + where + rest = t : addLay pos ts + + Right (pos@(ln, col), lexeme) + | ln > l -> Left (pos,Indent col) : t : rest + | otherwise -> t : rest + where + rest = case lexeme of + LexLET -> newlay CtxLet + LexLETSTRICT -> newlay CtxLet + LexWHERE -> newlay CtxLay + LexOF -> newlay CtxLay + LexDO -> newlay CtxLay + _ -> addLay pos ts + + newlay ctx = + case ts of + [] -> [] + u@(Right (pos',LexLBRACE)):us -> + u : addLay pos' us + u:us -> + let pos' = getPos u + in Left (pos', ctx (snd pos')) : u : addLay pos' us + +lay :: [Layout] -> [LayoutToken] -> [Token] +lay ctx tokens = + case tokens of + [] -> [] + + Left (pos, c):ts -> + case (ctx, c, ts) of + (CtxLet _:cs, Indent _, Right t@(post,LexIN):rest) -> + (post,LexRBRACE) : t : lay cs rest + + (CtxLet n:cs, Indent i, _) + | i == n -> (pos,LexSEMI) : lay ctx ts + | i < n -> (pos,LexRBRACE) : lay cs tokens + | otherwise -> lay ctx ts + + (CtxLay n:cs, Indent i, _) + | i == n -> (pos,LexSEMI) : lay ctx ts + | i < n -> (pos,LexRBRACE) : lay cs tokens + | otherwise -> lay ctx ts + + (CtxBrace:_, Indent _, _) -> lay ctx ts + (_,Indent _, _) -> lay ctx ts + + _ -> (pos,LexLBRACE) : lay (c:ctx) ts + + Right t@(pos, lexeme):ts -> + case (ctx, lexeme) of + (CtxLet _:cs, LexIN) -> (pos,LexRBRACE) : t : lay cs ts + (CtxLay _:cs, LexIN) -> (pos,LexRBRACE) : lay cs tokens + (CtxBrace:cs, LexRBRACE) -> t : lay cs ts + (_, LexLBRACE) -> t : lay (CtxBrace:ctx) ts + _ -> t : lay ctx ts + +doubleSemi :: [Token] -> [Token] +doubleSemi (t@(_, LexSEMI):(_, LexSEMI):rest) = doubleSemi (t:rest) +doubleSemi (t:ts) = t:doubleSemi ts +doubleSemi [] = [] diff --git a/Lvm/Core/Parsing/Lexer.hs b/Lvm/Core/Parsing/Lexer.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Parsing/Lexer.hs @@ -0,0 +1,375 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Lexer.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.Parsing.Lexer (lexer) where + +import Control.Monad +import Data.Char hiding (isSymbol, isLetter) +import Data.List +import Data.Maybe +import Lvm.Core.Parsing.Token + +type Lexer = Pos -> String -> [Token] +type Lexer5 = Pos -> String -> ([Token] -> [Token], Double, Pos, String) + +lexer :: Lexer +lexer (ln,_) [] = [((ln+1,0),LexEOF)] + +lexer pos ('-':'-':cs) = nextinc lexeol pos 2 cs +lexer pos ('{':'-':cs) = nextinc (lexComment 0) pos 2 cs + +lexer pos ('l':'e':'t':'!':cs) | nonId cs = (pos,LexLETSTRICT) : nextinc lexer pos 4 cs +lexer pos ('l':'e':'t':cs) | nonId cs = (pos,LexLET) : nextinc lexer pos 3 cs +lexer pos ('i':'n':cs) | nonId cs = (pos,LexIN) : nextinc lexer pos 2 cs +lexer pos ('d':'o':cs) | nonId cs = (pos,LexDO) : nextinc lexer pos 2 cs +lexer pos ('w':'h':'e':'r':'e':cs) | nonId cs = (pos,LexWHERE): nextinc lexer pos 5 cs +lexer pos ('c':'a':'s':'e':cs) | nonId cs = (pos,LexCASE) : nextinc lexer pos 4 cs +lexer pos ('o':'f':cs) | nonId cs = (pos,LexOF) : nextinc lexer pos 2 cs +lexer pos ('i':'f':cs) | nonId cs = (pos,LexIF) : nextinc lexer pos 2 cs +lexer pos ('t':'h':'e':'n':cs) | nonId cs = (pos,LexTHEN) : nextinc lexer pos 4 cs +lexer pos ('e':'l':'s':'e':cs) | nonId cs = (pos,LexELSE) : nextinc lexer pos 4 cs +lexer pos ('d':'a':'t':'a':cs) | nonId cs = (pos,LexDATA) : nextinc lexer pos 4 cs +lexer pos ('t':'y':'p':'e':cs) | nonId cs = (pos,LexTYPE) : nextinc lexer pos 4 cs +lexer pos ('m':'o':'d':'u':'l':'e':cs) | nonId cs = (pos,LexMODULE) : nextinc lexer pos 6 cs +lexer pos ('i':'m':'p':'o':'r':'t':cs) | nonId cs = (pos,LexIMPORT) : nextinc lexer pos 6 cs +-- not standard +lexer pos ('c':'o':'n':cs) | nonId cs = (pos,LexCON) : nextinc lexer pos 3 cs +lexer pos ('w':'i':'t':'h':cs) | nonId cs = (pos,LexWITH) : nextinc lexer pos 4 cs +lexer pos ('m':'a':'t':'c':'h':cs) | nonId cs = (pos,LexMATCH) : nextinc lexer pos 5 cs +lexer pos ('c':'c':'a':'l':'l':cs) | nonId cs = (pos,LexCCALL) : nextinc lexer pos 5 cs +lexer pos ('p':'u':'b':'l':'i':'c':cs) | nonId cs = (pos,LexPUBLIC) : nextinc lexer pos 6 cs +lexer pos ('e':'x':'t':'e':'r':'n':cs) | nonId cs = (pos,LexEXTERN) : nextinc lexer pos 6 cs +lexer pos ('s':'t':'a':'t':'i':'c':cs) | nonId cs = (pos,LexSTATIC) : nextinc lexer pos 6 cs +lexer pos ('c':'u':'s':'t':'o':'m':cs) | nonId cs = (pos,LexCUSTOM) : nextinc lexer pos 6 cs +lexer pos ('n':'o':'t':'h':'i':'n':'g':cs) | nonId cs = (pos,LexNOTHING) : nextinc lexer pos 7 cs +lexer pos ('p':'r':'i':'v':'a':'t':'e':cs) | nonId cs = (pos,LexPRIVATE) : nextinc lexer pos 7 cs +lexer pos ('d':'e':'f':'a':'u':'l':'t':cs) | nonId cs = (pos,LexDEFAULT) : nextinc lexer pos 7 cs +lexer pos ('d':'y':'n':'a':'m':'i':'c':cs) | nonId cs = (pos,LexDYNAMIC) : nextinc lexer pos 7 cs +lexer pos ('r':'u':'n':'t':'i':'m':'e':cs) | nonId cs = (pos,LexRUNTIME) : nextinc lexer pos 7 cs +lexer pos ('s':'t':'d':'c':'a':'l':'l':cs) | nonId cs = (pos,LexSTDCALL) : nextinc lexer pos 7 cs +lexer pos ('o':'r':'d':'i':'n':'a':'l':cs) | nonId cs = (pos,LexORDINAL) : nextinc lexer pos 7 cs +lexer pos ('d':'e':'c':'o':'r':'a':'t':'e':cs) | nonId cs = (pos,LexDECORATE) : nextinc lexer pos 8 cs +lexer pos ('a':'b':'s':'t':'r':'a':'c':'t':cs) | nonId cs = (pos,LexABSTRACT) : nextinc lexer pos 8 cs +lexer pos ('i':'n':'s':'t':'r':'c':'a':'l':'l':cs) | nonId cs = (pos,LexINSTRCALL) : nextinc lexer pos 9 cs +lexer pos ('i':'n':'s':'t':'r':'u':'c':'t':'i':'o':'n':cs) | nonId cs = (pos,LexINSTR) : nextinc lexer pos 11 cs + + +lexer pos (':':':':cs) | nonSym cs = (pos,LexCOLCOL) : nextinc lexer pos 2 cs +lexer pos ('=':'>':cs) | nonSym cs = (pos,LexARROW) : nextinc lexer pos 2 cs +lexer pos ('-':'>':cs) | nonSym cs = (pos,LexRARROW) : nextinc lexer pos 2 cs +lexer pos ('<':'-':cs) | nonSym cs = (pos,LexLARROW) : nextinc lexer pos 2 cs +lexer pos ('.':'.':cs) | nonSym cs = (pos,LexDOTDOT) : nextinc lexer pos 2 cs +lexer pos ('\'':'\'':cs) = nextinc (lexSpecialId pos) pos 2 cs + +lexer pos ('.':cs) | nonSym cs = (pos,LexDOT) : nextinc lexer pos 1 cs +lexer pos (',':cs) | nonSym cs = (pos,LexCOMMA) : nextinc lexer pos 1 cs +lexer pos ('`':cs) | nonSym cs = (pos,LexQUOTE) : nextinc lexer pos 1 cs +lexer pos (';':cs) | nonSym cs = (pos,LexSEMI) : nextinc lexer pos 1 cs +lexer pos ('|':cs) | nonSym cs = (pos,LexBAR) : nextinc lexer pos 1 cs +lexer pos ('~':cs) | nonSym cs = (pos,LexTILDE) : nextinc lexer pos 1 cs +lexer pos ('@':cs) | nonSym cs = (pos,LexAT) : nextinc lexer pos 1 cs +lexer pos ('=':cs) | nonSym cs = (pos,LexASG) : nextinc lexer pos 1 cs +lexer pos ('\\':cs) | nonSym cs = (pos,LexBSLASH) : nextinc lexer pos 1 cs +lexer pos ('!':cs) | nonSym cs = (pos,LexEXCL) : nextinc lexer pos 1 cs +lexer pos (':':cs) | nonSym cs = (pos,LexCOLON) : nextinc lexer pos 1 cs +-- lexer pos ('-':cs) | nonSym cs = (pos,LexDASH) : nextinc lexer pos 1 cs + +lexer pos ('(':cs) = (pos,LexLPAREN) : nextinc lexer pos 1 cs +lexer pos (')':cs) = (pos,LexRPAREN) : nextinc lexer pos 1 cs +lexer pos ('[':cs) = (pos,LexLBRACKET):nextinc lexer pos 1 cs +lexer pos (']':cs) = (pos,LexRBRACKET):nextinc lexer pos 1 cs +lexer pos ('{':cs) = (pos,LexLBRACE) : nextinc lexer pos 1 cs +lexer pos ('}':cs) = (pos,LexRBRACE) : nextinc lexer pos 1 cs + +lexer pos ('\'':cs) = nextinc lexChar pos 1 cs +lexer pos ('"':cs) = lexString (incpos pos 1) (pos,"") cs + +lexer pos ('0':cs) = lexZero pos cs + +lexer pos xs@(':':_) = lexWhile isSymbol LexConOp pos pos xs +lexer pos ('$':xs@(c:_)) | isLower c || c == '_' = let np = incpos pos 1 in lexWhile isLetter LexId np np xs +lexer pos xs@(c:cs) | isLower c || c == '_' = lexWhile isLetter LexId pos pos xs + | isUpper c = lexConOrQual pos xs + | isSpace c = next lexer pos c cs + | isSymbol c = lexWhile isSymbol LexOp pos pos xs + | isDigit c = lexIntFloat pos xs + | otherwise = (pos,LexUnknown c) : next lexer pos c cs + +next :: (Pos -> String -> a) -> Pos -> Char -> String -> a +next f pos c cs = let pos' = newpos pos c in seq pos' (f pos' cs) + +nextinc :: (Pos -> String -> a) -> Pos -> Int -> String -> a +nextinc f pos i cs = let pos' = incpos pos i in seq pos' (f pos' cs) + +lexConOrQual :: Lexer +lexConOrQual pos cs + = let (ident,rest) = span isLetter cs + pos' = foldl' newpos pos ident + in case rest of + '.':ds@(d:_) | isLower d || d == '_' + -> lexWhile isLetter (LexQualId ident) pos (incpos pos' 1) ds + | isUpper d -> lexWhile isLetter (LexQualCon ident) pos (incpos pos' 1) ds + | isSymbol d -> lexWhile isSymbol (LexQualId ident) pos (incpos pos' 1) ds + '.':'\'':'\'':ds -> case lexSpecialId pos (incpos pos 3) ds of + (pos1, LexCon s):xs -> (pos1, LexQualCon ident s):xs + (pos1, LexId s):xs -> (pos1, LexQualId ident s):xs + xs -> xs + _ -> (pos,LexCon ident) : seq pos' (lexer pos' rest) + +lexWhile :: (Char -> Bool) -> (String -> Lexeme) -> Pos -> Lexer +lexWhile ctype con pos0 pos cs = let (ident,rest) = span ctype cs + pos' = foldl' newpos pos ident + in (pos0,con ident) : seq pos' (lexer pos' rest) + +lexSpecialId :: Pos -> Lexer +lexSpecialId originalPos pos cs -- originalPos points to where '' started. it should + -- be used as the position of the identifier because of the layout rule + -- y = 4 + -- ''x'' = 3 -- x and y should be in the same context + = let (ident,rest) = span (\c -> not (isSpace c) && c /= '\'') cs in + case rest of + ('\'':'\'':cs')-> let pos' = foldl' newpos pos (ident ++ "''") in + seq pos' $ + case ident of + [] -> (originalPos,LexError "empty special identifier") : lexer pos' cs' + -- ":" -> (originalPos,LexError "empty special con identifier") : lexer pos' cs' + ":" -> (originalPos,LexId ident) : lexer pos' cs' + ':':conid -> (originalPos,LexCon conid) : lexer pos' cs' + _ -> (originalPos,LexId ident) : lexer pos' cs' + _ -> let pos' = foldl' newpos pos ident in + (pos',LexError ("expecting '' after special identifier " ++ show ident)):lexer pos' rest + +----------------------------------------------------------- +-- Numbers +----------------------------------------------------------- + +lexZero :: Lexer +lexZero pos (c:cs) | c == 'o' || c == 'O' = case octal pos' cs of + Just (i,pos'',cs') -> (pos, LexInt i) : lexer pos'' cs' + Nothing -> (pos, LexError "illegal octal number") + : lexer pos' cs + | c == 'x' || c == 'X' = case hexal pos' cs of + Just (i,pos'',cs') -> (pos, LexInt i) : lexer pos'' cs' + Nothing -> (pos, LexError "illegal hexadecimal number") + : lexer pos' cs + | c == '.' = lexFloat 0 pos' cs + | isDigit c = lexIntFloat pos (c:cs) + | otherwise = (pos,LexInt 0) : lexer pos' (c:cs) + where + pos' = newpos (newpos pos '0') c +lexZero pos cs = (pos,LexInt 0) : lexer (newpos pos '0') cs + +lexIntFloat :: Lexer +lexIntFloat pos cs = case decimal pos cs of + Just (i,pos',cs') -> + case cs' of ('.':cs'') -> lexFloat i (newpos pos' '.') cs'' + _ -> (pos,LexInt i) : lexer pos' cs' + _ -> error "lexIntFloat" + +lexFloat :: Integer -> Lexer +lexFloat i pos cs = let (fracterr,fract,pos',cs') = lexFract pos cs + (experr,expon,pos'',cs'') = lexExponent pos' cs' + in fracterr (experr ( (pos,LexFloat ((fromInteger i + fract) * expon)) : lexer pos'' cs'')) + +lexFract :: Lexer5 +lexFract pos cs = let (xs,rest) = span isDigit cs + in if null xs + then ( ((pos,LexError "invalid fraction") :), 0.0, pos, cs ) + else ( id, foldr op 0.0 xs, foldl' newpos pos xs, rest ) + where + c `op` f = (f + fromIntegral (fromEnum c - fromEnum '0'))/10.0 + +lexExponent :: Lexer5 +lexExponent pos (c:cs) | c == 'e' || c == 'E' = case cs of ('-':cs') -> lexExp negate (incpos pos 2) cs' + ('+':cs') -> lexExp id (incpos pos 2) cs' + _ -> lexExp id (incpos pos 1) cs +lexExponent pos cs = (id, 1.0, pos, cs) + +lexExp :: (Integer -> Integer) -> Lexer5 +lexExp f pos cs = case decimal pos cs of + Just (i,pos',cs') -> (id,power (f i),pos',cs') + Nothing -> (((pos,LexError "invalid exponent"):), 1.0, pos, cs ) + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + +hexal, octal, decimal :: Pos -> String -> Maybe (Integer, Pos, String) +hexal = number 16 isHexal +octal = number 8 isOctal +decimal = number 10 isDigit + +number ::Integer-> (Char -> Bool) -> Pos -> String -> Maybe (Integer,Pos,String) +number base test pos cs = let (xs,rest) = span test cs + in if null xs + then Nothing + else Just (foldl' op 0 xs, foldl' newpos pos xs, rest) + where + x `op` y = base*x + fromIntegral (fromChar y) + fromChar c | isDigit c = fromEnum c - fromEnum '0' + | otherwise = fromEnum (toUpper c) - fromEnum 'A' + +isOctal, isHexal :: Char -> Bool +isOctal = isOctDigit +isHexal = isHexDigit + +----------------------------------------------------------- +-- Characters +----------------------------------------------------------- + +lexChar :: Lexer +lexChar pos ('\\':cs) = let (pos',lexeme,xs) = escapeChar pos cs + in lexEndChar lexeme pos' xs +lexChar pos ('\'':cs) = (pos,LexError "empty character") : nextinc lexer pos 1 cs + +lexChar pos (c:cs) | isGraphic c || c == '"' || c == ' ' = lexEndChar (pos,LexChar c) (incpos pos 1) cs + | otherwise = (pos,LexError "invalid character") : next lexer pos c cs + +lexChar pos [] = (pos,LexError "unexpected end of input in character") : lexer pos [] + +lexEndChar :: Token -> Lexer +lexEndChar lexeme pos ('\'':cs) = lexeme : nextinc lexer pos 1 cs +lexEndChar _ pos cs = (pos,LexError "expecting termiInting symbol \"'\"") : lexer pos cs + + +lexString :: Pos -> (Pos, String) -> String -> [Token] +lexString pos (p,s) ('"':cs) = (p,LexString (reverse s)) : nextinc lexer pos 1 cs + +lexString pos (p,s) ('\n':cs) = (p,LexString (reverse s)) : (pos,LexError "newline in string") : next lexer pos '\n' cs + +lexString pos (p,s) ('\\':c:cs) | isSpace c = gap (incpos pos 1) (p,s) cs + | c == '&' = lexString (incpos pos 2) (p,s) cs + | otherwise = let (pos',(_,lexeme),cs') = escapeChar pos (c:cs) + in case lexeme of + LexChar d -> lexString pos' (p,d:s) cs' + _ -> (pos,LexError "illegal escape sequence") : + lexString pos' (p,s) cs' + +lexString pos (p,s) [] = (p,LexString (reverse s)) + : (pos,LexError "unexpected end of input in string") + : lexer pos [] +lexString pos (p,s) ['\\'] = lexString (incpos pos 1) (p,s) [] + +lexString pos (p,s) (c:cs) | isGraphic c || c == '\'' || c == ' ' + = lexString (incpos pos 1) (p,c:s) cs + | otherwise = (pos,LexError ("illegal character (" ++ [c] ++ ") in string")) + : lexString (newpos pos c) (p,s) cs + +gap :: Pos -> (Pos, String) -> String -> [Token] +gap pos (p,s) cs = let (ws,rest) = span isSpace cs + pos' = foldl' newpos pos ws + in case rest of + ('\\':cs') -> lexString pos' (p,s) cs' + _ -> (pos',LexError "(\\) expected at end of gap") + : lexString pos' (p,s) rest + +----------------------------------------------------------- +-- Escape sequences +----------------------------------------------------------- + + +escapeChar :: Pos -> String -> (Pos,Token,String) +escapeChar pos [] = (pos,(pos,LexError "Unexpected end of input"),[]) +escapeChar pos cs = fromMaybe def (msum [ f pos cs | f <- fs ]) + where + def = (pos,(pos,LexError "invalid escape sequence"),cs) + fs = [ascii3, ascii2, escape, control, charnum] + +charnum :: Pos -> String -> Maybe (Pos,Token,String) +charnum pos ('x':cs) = numToChar pos (hexal (incpos pos 1) cs) +charnum pos ('o':cs) = numToChar pos (octal (incpos pos 1) cs) +charnum pos ('d':cs) = numToChar pos (decimal (incpos pos 1) cs) +charnum pos (c:cs) | isDigit c = numToChar pos (decimal (incpos pos 1) cs) +charnum _ _ = Nothing + +numToChar :: Pos -> Maybe (Integer, Pos, String) -> Maybe (Pos, Token, String) +numToChar pos (Just (x,pos',cs')) = Just (pos',(pos,LexChar (toEnum (fromInteger x))), cs') +numToChar _ _ = Nothing + + + +control :: Pos -> String -> Maybe (Pos,Token,String) +control pos ('^':c:cs) | isUpper c = let x = toEnum (fromEnum c - fromEnum 'A') + in Just (incpos pos 2, (pos,LexChar x), cs) +control _ _ = Nothing + + + +escape :: Pos -> String -> Maybe (Pos,Token,String) +escape pos (c:cs) = case lookup c escapemap of + Just k -> Just (incpos pos 1, (pos,LexChar k), cs) + Nothing -> Nothing +escape _ _ = Nothing + +ascii2 :: Pos -> String -> Maybe (Pos,Token,String) +ascii2 pos (x:y:cs) = case lookup [x,y] ascii2map of + Just k -> Just (incpos pos 2, (pos,LexChar k), cs) + Nothing -> Nothing +ascii2 _ _ = Nothing + +ascii3 :: Pos -> String -> Maybe (Pos,Token,String) +ascii3 pos (x:y:z:cs)= case lookup [x,y,z] ascii3map of + Just k -> Just (incpos pos 3, (pos,LexChar k), cs) + Nothing -> Nothing +ascii3 _ _ = Nothing + + + +escapemap :: [(Char, Char)] +escapemap = zip "abfnrtv\\\"\'" + "\a\b\f\n\r\t\v\\\"\'" + +ascii2map :: [(String, Char)] +ascii2map = zip ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] + "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" + +ascii3map :: [(String, Char)] +ascii3map = zip ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" + + +----------------------------------------------------------- +-- Symbols +----------------------------------------------------------- + +isSpecial, isSmall, isLarge, isLetter, isSymbol :: Char -> Bool +isSpecial = (`elem` "(),;[]`{}") +isSmall c = isLower c || c == '_' +isLarge = isUpper +isLetter c = isSmall c || isLarge c || isDigit c || c == '\'' +isSymbol = (`elem` "!#$%&*+./<=>?@\\^|-~:") + +isGraphic :: Char -> Bool +isGraphic c = isLetter c || isSymbol c || isSpecial c || (c == ':') || (c == '"') + +nonId :: String -> Bool +nonId (c:_) = not (isLetter c) +nonId [] = True + +nonSym :: String -> Bool +nonSym (c:_) = not (isSymbol c) +nonSym [] = True + +----------------------------------------------------------- +-- Comment +----------------------------------------------------------- + +lexeol :: Lexer +lexeol pos ('\n':cs) = lexer (newpos pos '\n') cs +lexeol pos (c:cs) = lexeol (newpos pos c) cs +lexeol pos [] = lexer pos [] + +lexComment :: Int -> Lexer +lexComment level pos s = + case s of + '-':'}':cs | level == 0 -> lexer (incpos pos 2) cs + | otherwise -> lexComment (level - 1) (incpos pos 2) cs + '{':'-':cs -> lexComment (level+1) (incpos pos 2) cs + c:cs -> lexComment level (newpos pos c) cs + [] -> lexer pos [] diff --git a/Lvm/Core/Parsing/Parser.hs b/Lvm/Core/Parsing/Parser.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Parsing/Parser.hs @@ -0,0 +1,1014 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Parser.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.Parsing.Parser (parseModuleExport, parseModule) where + +import Control.Monad +import Data.List +import Lvm.Common.Byte +import Lvm.Common.Id +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.Parsing.Token (Token, Lexeme(..)) +import Lvm.Core.Type +import Lvm.Core.Utils +import Prelude hiding (lex) +import Text.ParserCombinators.Parsec hiding (satisfy) + +parseModuleExport :: FilePath -> [Token] -> IO (CoreModule, Bool, (IdSet,IdSet,IdSet,IdSet,IdSet)) +parseModuleExport fname ts = + case runParser pmodule () fname ts of + Left err + -> ioError (userError ("parse error: " ++ show err)) + Right res + -> return res + +parseModule :: FilePath -> [Token] -> IO CoreModule +parseModule fname = liftM (\(m, _, _) -> m) . parseModuleExport fname + +---------------------------------------------------------------- +-- Basic parsers +---------------------------------------------------------------- +type TokenParser a = GenParser Token () a + +---------------------------------------------------------------- +-- Program +---------------------------------------------------------------- + +wrap :: TokenParser a -> TokenParser [a] +wrap p + = do{ x <- p; return [x] } + +pmodule :: TokenParser (CoreModule, Bool, (IdSet,IdSet,IdSet,IdSet,IdSet)) +pmodule = + do{ lexeme LexMODULE + ; moduleId <- conid "module name" + ; exports <- pexports + ; lexeme LexWHERE + ; lexeme LexLBRACE + ; declss <- semiList (wrap (ptopDecl <|> pconDecl <|> pabstract <|> pextern <|> pCustomDecl) + <|> pdata <|> pimport <|> ptypeTopDecl) + ; lexeme LexRBRACE + ; lexeme LexEOF + + ; return $ + case exports of + Nothing -> + let es = (emptySet,emptySet,emptySet,emptySet,emptySet) + in + ( modulePublic + True + es + (Module moduleId 0 0 (concat declss)) + , True + , es + ) + Just es -> + ( modulePublic + False + es + (Module moduleId 0 0 (concat declss)) + , False + , es + ) + + } + +---------------------------------------------------------------- +-- export list +---------------------------------------------------------------- +data Export = ExportValue Id + | ExportCon Id + | ExportData Id + | ExportDataCon Id + | ExportModule Id + +pexports :: TokenParser (Maybe (IdSet,IdSet,IdSet,IdSet,IdSet)) +pexports + = do{ exports <- commaParens pexport <|> return [] + ; return $ + if null (concat exports) then + Nothing + else + Just (foldl' + split + (emptySet,emptySet,emptySet,emptySet,emptySet) + (concat exports) + ) + } + where + split (values,cons,datas,datacons,ms) export + = case export of + ExportValue x -> (insertSet x values,cons,datas,datacons,ms) + ExportCon x -> (values,insertSet x cons,datas,datacons,ms) + ExportData x -> (values,cons,insertSet x datas,datacons,ms) + ExportDataCon x -> (values,cons,datas,insertSet x datacons,ms) + ExportModule x -> (values,cons,datas,datacons,insertSet x ms) + +pexport :: TokenParser [Export] +pexport + = do{ lexeme LexLPAREN + ; entity <- + do { x <- opid ; return (ExportValue x) } + <|> + do { x <- conopid; return (ExportCon x) } + ; lexeme LexRPAREN + ; return [entity] + } + <|> + do{ x <- varid + ; return [ExportValue x] + } + <|> + do{ x <- typeid + ; do{ lexeme LexLPAREN + ; cons <- pexportCons x + ; lexeme LexRPAREN + ; return (ExportData x:cons) + } + <|> + -- no parenthesis: could be either a + -- constructor or a type constructor + return [ExportData x, ExportCon x] + } + <|> + do{ lexeme LexMODULE + ; x <- conid + ; return [ExportModule x] + } + +pexportCons :: Id -> TokenParser [Export] +pexportCons x + = do{ lexeme LexDOTDOT + ; return [ExportDataCon x] + } + <|> + do{ xs <- sepBy constructor (lexeme LexCOMMA) + ; return (map ExportCon xs) + } + + +---------------------------------------------------------------- +-- abstract declarations +---------------------------------------------------------------- +pabstract :: TokenParser CoreDecl +pabstract + = do{ lexeme LexABSTRACT + ; pabstractValue <|> pabstractCon + } + +pabstractValue :: TokenParser (Decl v) +pabstractValue + = do{ x <- variable + ; (acc,custom) <- pAttributes private + ; lexeme LexASG + ; (mid,impid) <- qualifiedVar + ; arity <- liftM fromInteger lexInt + <|> liftM (arityFromType . fst) ptypeDecl + ; let access | isImported acc = acc + | otherwise = Imported False mid impid DeclKindValue 0 0 + ; return (DeclAbstract x access arity custom) + } + +pabstractCon :: TokenParser (Decl v) +pabstractCon + = do{ x <- conid + ; (acc,custom) <- pAttributes private -- ignore access + ; lexeme LexASG + ; (mid,impid) <- qualifiedCon + ; (tag, arity) <- pConInfo + ; let access | isImported acc = acc + | otherwise = Imported False mid impid DeclKindCon 0 0 + ; return (DeclCon x access arity tag custom) + } + +isImported :: Access -> Bool +isImported (Imported {}) = True +isImported _ = False + +---------------------------------------------------------------- +-- import declarations +---------------------------------------------------------------- +pimport :: TokenParser [CoreDecl] +pimport + = do{ lexeme LexIMPORT + ; mid <- conid + ; do{ xss <- commaParens (pImportSpec mid) + ; return (concat xss) + } + <|> + return [DeclImport mid (Imported False mid dummyId DeclKindModule 0 0) []] + } + +pImportSpec :: Id -> TokenParser [CoreDecl] +pImportSpec mid + = do{ lexeme LexLPAREN + ; (kind, x) <- + do { y <- opid ; return (DeclKindValue, y) } + <|> + do { y <- conopid; return (DeclKindCon , y) } + ; lexeme LexRPAREN + ; impid <- option x (do{ lexeme LexASG; variable }) + ; return [DeclImport x (Imported False mid impid kind 0 0) []] + } + <|> + do{ x <- varid + ; impid <- option x (do{ lexeme LexASG; variable }) + ; return [DeclImport x (Imported False mid impid DeclKindValue 0 0) []] + } + <|> + do{ lexeme LexCUSTOM + ; kind <- lexString + ; x <- variable <|> constructor + ; impid <- option x (do { lexeme LexASG; variable <|> constructor }) + ; return [DeclImport x (Imported False mid impid (customDeclKind kind) 0 0) []] + } + <|> + do{ x <- typeid + ; impid <- option x (do{ lexeme LexASG; variable }) + ; do{ lexeme LexLPAREN + ; cons <- pImportCons mid + ; lexeme LexRPAREN + ; return (DeclImport x (Imported False mid impid customData 0 0) [] : cons) + } + <|> + return + [DeclImport x (Imported False mid impid DeclKindCon 0 0) []] + } + +pImportCons :: Id -> TokenParser [CoreDecl] +pImportCons mid + = -- do{ lexeme LexDOTDOT + -- ; return [ExportDataCon id] + -- } + -- <|> + sepBy (pimportCon mid) (lexeme LexCOMMA) + +pimportCon :: Id -> TokenParser CoreDecl +pimportCon mid + = do{ x <- constructor + ; impid <- option x (do{ lexeme LexASG; variable }) + ; return (DeclImport x (Imported False mid impid DeclKindCon 0 0) []) + } + +---------------------------------------------------------------- +-- constructor declarations +---------------------------------------------------------------- + +pconDecl :: TokenParser CoreDecl +pconDecl = do + lexeme LexCON + x <- constructor + (access,custom) <- pAttributes public + lexeme LexASG + (tag, arity) <- pConInfo + return $ DeclCon x access arity tag custom + +-- constructor info: (@tag, arity) +pConInfo :: TokenParser (Tag, Arity) +pConInfo = (parens $ do + lexeme LexAT + tag <- lexInt "tag" + lexeme LexCOMMA + arity <- lexInt "arity" + return (fromInteger tag, fromInteger arity)) + <|> do -- :: TypeSig = tag + (tp, _) <- ptypeDecl + lexeme LexASG + tag <- lexInt "tag" + return (fromInteger tag, arityFromType tp) + + +---------------------------------------------------------------- +-- value declarations +---------------------------------------------------------------- + +ptopDecl :: TokenParser CoreDecl +ptopDecl + = do{ x <- variable + ; ptopDeclType x <|> ptopDeclDirect x + } + +ptopDeclType :: Id -> TokenParser (Decl Expr) +ptopDeclType x + = do{ (tp,_) <- ptypeDecl + ; lexeme LexSEMI + ; x2 <- variable + ; when (x /= x2) $ fail + ( "identifier for type signature " + ++ stringFromId x + ++ " doesn't match the definition" + ++ stringFromId x2 + ) + ; (access,custom,expr) <- pbindTopRhs + ; return (DeclValue x access Nothing expr + (customType tp : custom)) + } + +ptopDeclDirect :: Id -> TokenParser (Decl Expr) +ptopDeclDirect x + = do{ (access,custom,expr) <- pbindTopRhs + ; return (DeclValue x access Nothing expr custom) + } + +pbindTopRhs :: TokenParser (Access, [Custom], Expr) +pbindTopRhs + = do{ args <- many bindid + ; (access,custom) <- pAttributes public + ; lexeme LexASG + ; body <- pexpr + ; let expr = foldr Lam body args + ; return (access,custom,expr) + } + "declaration" + + + +pbind :: TokenParser Bind +pbind + = do{ x <- variable + ; expr <- pbindRhs + ; return (Bind x expr) + } + +pbindRhs :: TokenParser Expr +pbindRhs + = do{ args <- many bindid + ; lexeme LexASG + ; body <- pexpr + ; let expr = foldr Lam body args + ; return expr + } + "declaration" + +---------------------------------------------------------------- +-- data declarations +---------------------------------------------------------------- + +makeCustomBytes :: String -> Bytes -> Custom +makeCustomBytes k bs = CustomDecl (customDeclKind k) [CustomBytes bs] + +customType :: Type -> Custom +customType = makeCustomBytes "type" . bytesFromString . show + +customKind :: Kind -> Custom +customKind = makeCustomBytes "kind" . bytesFromString . show + +pdata :: TokenParser [CoreDecl] +pdata + = do{ lexeme LexDATA + ; x <- typeid + ; args <- many typevarid + ; let kind = foldr (KFun . const KStar) KStar args + datadecl = DeclCustom x public customData [customKind kind] + ; do{ lexeme LexASG + ; let t1 = foldl TAp (TCon x) (map TVar args) + ; cons <- sepBy1 (pconstructor t1) (lexeme LexBAR) + ; let con tag (cid,t2) = DeclCon cid public (arityFromType t2) tag + [customType t2, + CustomLink x customData] + ; return (datadecl:zipWith con [0..] cons) + } + <|> {- empty data types -} + return [datadecl] + } + +pconstructor :: Type -> TokenParser (Id,Type) +pconstructor tp + = do{ x <- constructor + ; args <- many ptypeAtom + ; return (x,foldr TFun tp args) + } + +---------------------------------------------------------------- +-- type declarations +---------------------------------------------------------------- + +ptypeTopDecl :: TokenParser [CoreDecl] +ptypeTopDecl + = do{ lexeme LexTYPE + ; x <- typeid + ; args <- many typevarid + ; lexeme LexASG + ; tp <- ptype + ; let kind = foldr (KFun . const KStar) KStar args + tpstr = unwords $ stringFromId x + : map stringFromId args + ++ ["=", show tp] + ; return [DeclCustom x private customTypeDecl + [CustomBytes (bytesFromString tpstr) + ,customKind kind]] + } + +---------------------------------------------------------------- +-- Custom +---------------------------------------------------------------- +pCustomDecl :: TokenParser CoreDecl +pCustomDecl + = do{ lexeme LexCUSTOM + ; kind <- pdeclKind + ; x <- customid + ; (access,customs) <- pAttributes private + ; return (DeclCustom x access kind customs) + } + +pAttributes :: Access -> TokenParser (Access,[Custom]) +pAttributes defAccess + = do{ lexeme LexCOLON + ; access <- paccess defAccess + ; customs <- pcustoms + ; return (access, customs) + } + <|> return (private,[]) + +paccess :: Access -> TokenParser Access +paccess defAccess + = do{ lexeme LexPRIVATE; pimportaccess False <|> return private } + <|> do{ lexeme LexPUBLIC; pimportaccess True <|> return public } + <|> return defAccess + +pimportaccess :: Bool -> TokenParser Access +pimportaccess isPublic = do + lexeme LexIMPORT + kind <- pdeclKind + (m, x) <- lexQualifiedId + return $ Imported isPublic (idFromString m) (idFromString x) kind 0 0 + +pcustoms :: TokenParser [Custom] +pcustoms + = do{ lexeme LexLBRACKET + ; customs <- pcustom `sepBy` lexeme LexCOMMA + ; lexeme LexRBRACKET + ; return customs + } + <|> return [] + +pcustom :: TokenParser Custom +pcustom + = do{ i <- lexInt; return (CustomInt (fromInteger i)) } + <|> do{ s <- lexString; return (CustomBytes (bytesFromString s)) } + <|> do{ x <- variable <|> constructor; return (CustomName x) } + <|> do{ lexeme LexNOTHING; return CustomNothing } + <|> do{ lexeme LexCUSTOM + ; kind <- pdeclKind + ; do{ x <- customid + ; return (CustomLink x kind) + } + <|> + do{ cs <- pcustoms + ; return (CustomDecl kind cs) + } + } + "custom value" + +pdeclKind :: TokenParser DeclKind +pdeclKind + = do{ x <- varid; return (makeDeclKind x) } + <|> do{ i <- lexInt; return (toEnum (fromInteger i)) } + <|> do{ s <- lexString; return (customDeclKind s) } + "custom kind" + +---------------------------------------------------------------- +-- Expressions +---------------------------------------------------------------- + +pexpr :: TokenParser Expr +pexpr + = do{ lexeme LexBSLASH + ; args <- many bindid + ; lexeme LexRARROW + ; expr <- pexpr + ; return (foldr Lam expr args) + } + <|> + do{ lexeme LexLET + ; binds <- semiBraces pbind + ; lexeme LexIN + ; expr <- pexpr + ; return (Let (Rec binds) expr) + } + <|> + do{ lexeme LexCASE + ; expr <- pexpr + ; lexeme LexOF + ; (x,alts) <- palts + ; case alts of + [Alt PatDefault rhs] -> return (Let (Strict (Bind x expr)) rhs) + _ -> return (Let (Strict (Bind x expr)) (Match x alts)) + } + <|> + do{ lexeme LexMATCH + ; x <- variable + ; lexeme LexWITH + ; (defid,alts) <- palts + ; case alts of + -- better approach is to optize these cases *after* parsing + [Alt PatDefault rhs] + | x == defid -> return rhs + | otherwise -> return (Let (NonRec (Bind defid (Var x))) rhs) + _ | x == defid -> return (Match x alts) + | defid == wildId -> return (Match x alts) + | otherwise -> return (Let (NonRec (Bind defid (Var x))) (Match defid alts)) + } + <|> + do{ lexeme LexLETSTRICT + ; binds <- semiBraces pbind + ; lexeme LexIN + ; expr <- pexpr + ; return (foldr (Let . Strict) expr binds) + } + <|> pexprAp + "expression" + +wildId :: Id +wildId = idFromString "_" + +pexprAp :: TokenParser Expr +pexprAp + = do{ atoms <- many1 patom + ; return (foldl1 Ap atoms) + } + +patom :: TokenParser Expr +patom + = do{ x <- varid; return (Var x) } + <|> do{ x <- conid; return (Con (ConId x)) } + <|> do{ lit <- pliteral; return (Lit lit) } + <|> parenExpr + <|> listExpr + "atomic expression" + + +listExpr :: TokenParser Expr +listExpr + = do{ lexeme LexLBRACKET + ; exprs <- sepBy pexpr (lexeme LexCOMMA) + ; lexeme LexRBRACKET + ; return (foldr cons nil exprs) + } + where + cons = Ap . Ap (Con (ConId (idFromString ":"))) + nil = Con (ConId (idFromString "[]")) + +parenExpr :: TokenParser Expr +parenExpr + = do{ lexeme LexLPAREN + ; expr <- do{ x <- opid + ; return (Var x) + } + <|> + do{ x <- conopid + ; return (Con (ConId x)) + } + <|> + do{ lexeme LexAT + ; tag <- ptagExpr + ; lexeme LexCOMMA + ; arity <- lexInt "arity" + ; return (Con (ConTag tag (fromInteger arity))) + } + <|> + do{ exprs <- pexpr `sepBy` lexeme LexCOMMA + ; case exprs of + [expr] -> return expr + _ -> let con = Con (ConTag (Lit (LitInt 0)) (length exprs)) + tup = foldl Ap con exprs + in return tup + } + ; lexeme LexRPAREN + ; return expr + } + +ptagExpr :: TokenParser Expr +ptagExpr + = do{ i <- lexInt; return (Lit (LitInt (fromInteger i))) } + <|> do{ x <- variable; return (Var x) } + "tag (integer or variable)" + +pliteral :: TokenParser Literal +pliteral + = pnumber id id + <|> do{ s <- lexString; return (LitBytes (bytesFromString s)) } + <|> do{ c <- lexChar; return (LitInt (fromEnum c)) } + <|> do{ lexeme LexDASH + ; pnumber negate negate + } + "literal" + +pnumber :: (Int -> Int) -> (Double -> Double) -> TokenParser Literal +pnumber signint signdouble + = do{ i <- lexInt; return (LitInt (signint (fromInteger i))) } + <|> do{ d <- lexDouble; return (LitDouble (signdouble d)) } + +---------------------------------------------------------------- +-- alternatives +---------------------------------------------------------------- +palts :: TokenParser (Id,Alts) +palts + = do{ lexeme LexLBRACE + ; (x,alts) <- paltSemis + ; return (x,alts) + } + +paltSemis :: TokenParser (Id,Alts) +paltSemis + = do{ (x,alt) <- paltDefault + ; optional (lexeme LexSEMI) + ; lexeme LexRBRACE + ; return (x,[alt]) + } + <|> + do{ alt <- palt + ; do{ lexeme LexSEMI + ; do{ (x,alts) <- paltSemis + ; return (x,alt:alts) + } + <|> do{ lexeme LexRBRACE + ; x <- wildcard + ; return (x,[alt]) + } + } + <|> do{ lexeme LexRBRACE + ; x <- wildcard + ; return (x,[alt]) + } + } + +palt :: TokenParser Alt +palt + = do{ pat <- ppat + ; lexeme LexRARROW + ; expr <- pexpr + ; return (Alt pat expr) + } + +ppat :: TokenParser Pat +ppat + = ppatCon <|> ppatLit <|> ppatParens + +ppatParens :: TokenParser Pat +ppatParens + = do{ lexeme LexLPAREN + ; do{ lexeme LexAT + ; tag <- lexInt "tag" + ; lexeme LexCOMMA + ; arity <- lexInt "arity" + ; lexeme LexRPAREN + ; ids <- many bindid + ; return (PatCon (ConTag (fromInteger tag) (fromInteger arity)) ids) + } + <|> + do{ x <- conopid + ; lexeme LexRPAREN + ; ids <- many bindid + ; return (PatCon (ConId x) ids) + } + <|> + do{ pat <- ppat <|> ppatTuple + ; lexeme LexRPAREN + ; return pat + } + } + +ppatCon :: TokenParser Pat +ppatCon + = do{ x <- conid <|> do{ lexeme LexLBRACKET; lexeme LexRBRACKET; return (idFromString "[]") } + ; args <- many bindid + ; return (PatCon (ConId x) args) + } + +ppatLit :: TokenParser Pat +ppatLit + = do{ lit <- pliteral; return (PatLit lit) } + +ppatTuple :: TokenParser Pat +ppatTuple + = do{ ids <- bindid `sepBy` lexeme LexCOMMA + ; return (PatCon (ConTag 0 (length ids)) ids) + } + +paltDefault :: TokenParser (Id, Alt) +paltDefault + = do{ x <- bindid <|> do{ lexeme LexDEFAULT; wildcard } + ; lexeme LexRARROW + ; expr <- pexpr + ; return (x,Alt PatDefault expr) + } + +wildcard :: TokenParser Id +wildcard + = identifier (return "_") + +---------------------------------------------------------------- +-- externs +---------------------------------------------------------------- +pextern :: TokenParser CoreDecl +pextern + = do{ lexeme LexEXTERN + ; linkConv <- plinkConv + ; callConv <- pcallConv + ; x <- varid + ; m <- lexString <|> return (stringFromId x) + ; (mname,name) <- pExternName m + ; (tp,arity) <- ptypeDecl + ; return (DeclExtern x private arity (show tp) linkConv callConv mname name []) + } + <|> + do{ lexeme LexINSTR + ; x <- varid + ; s <- lexString + ; (tp,arity) <- ptypeDecl + ; return (DeclExtern x private arity (show tp) LinkStatic CallInstr "" (Plain s) []) + } + +------------------ + +plinkConv :: TokenParser LinkConv +plinkConv + = do{ lexeme LexSTATIC; return LinkStatic } + <|> do{ lexeme LexDYNAMIC; return LinkDynamic } + <|> do{ lexeme LexRUNTIME; return LinkRuntime } + <|> return LinkStatic + +pcallConv :: TokenParser CallConv +pcallConv + = do{ lexeme LexCCALL; return CallC } + <|> do{ lexeme LexSTDCALL; return CallStd } + <|> do{ lexeme LexINSTRCALL; return CallInstr } + <|> return CallC + +pExternName :: String -> TokenParser (String, ExternName) +pExternName mname + = do{ lexeme LexDECORATE + ; name <- lexString + ; return (mname,Decorate name) + } + <|> do{ lexeme LexORDINAL + ; ord <- lexInt + ; return (mname,Ordinal (fromIntegral ord)) + } + <|> do{ name <- lexString + ; return (mname,Plain name) + } + <|> return ("",Plain mname) + + +---------------------------------------------------------------- +-- types +---------------------------------------------------------------- + +ptypeDecl :: TokenParser (Type, Int) +ptypeDecl + = do{ lexeme LexCOLCOL + ; ptypeNormal <|> ptypeString + } + +ptypeNormal :: TokenParser (Type, Int) +ptypeNormal + = do{ tp <- ptype + ; return (tp,arityFromType tp) + } + + +ptype :: TokenParser Type +ptype + = ptypeFun + +ptypeFun :: TokenParser Type +ptypeFun + = chainr1 ptypeAp pFun + where + pFun = do{ lexeme LexRARROW; return TFun } + +ptypeAp :: TokenParser Type +ptypeAp + = do{ atoms <- many1 ptypeAtom + ; return (foldl1 TAp atoms) + } + +ptypeAtom :: TokenParser Type +ptypeAtom + = do{ x <- typeid + ; ptypeStrict (TCon x) + } + <|> + do{ x <- typevarid + ; ptypeStrict (TVar x) + } + <|> listType + <|> parenType + "atomic type" + +ptypeStrict :: Type -> TokenParser Type +ptypeStrict tp + = do{ lexeme LexEXCL + ; return (TStrict tp) + } + <|> return tp + +parenType :: TokenParser Type +parenType + = do{ lexeme LexLPAREN + ; tps <- sepBy ptype (lexeme LexCOMMA) + ; lexeme LexRPAREN + ; case tps of + [] -> do{ x <- identifier (return "()"); return (TCon x) } -- (setSortId SortType id)) + [tp] -> return tp + _ -> return + (foldl + TAp + (TCon (idFromString + ( "(" + ++ replicate (length tps - 1) ',' + ++ ")" + ))) + tps + ) + } + +listType :: TokenParser Type +listType + = do{ lexeme LexLBRACKET + ; do{ tp <- ptype + ; lexeme LexRBRACKET + ; x <- identifier (return "[]") + ; return (TAp (TCon x {- (setSortId SortType id) -}) tp) + } + <|> + do{ lexeme LexRBRACKET + ; x <- identifier (return "[]") + ; return (TCon x {-(setSortId SortType id)-}) + } + } + +ptypeString :: TokenParser (Type, Int) +ptypeString + = do{ s <- lexString + ; return (TString s, length s-1) + } + +---------------------------------------------------------------- +-- helpers +---------------------------------------------------------------- + +semiBraces, commaParens :: TokenParser a -> TokenParser [a] +semiBraces p = braces (semiList p) +commaParens p = parens (sepBy p (lexeme LexCOMMA)) + +braces, parens :: TokenParser a -> TokenParser a +braces = between (lexeme LexLBRACE) (lexeme LexRBRACE) +parens = between (lexeme LexLPAREN) (lexeme LexRPAREN) + +-- terminated or separated +semiList1 :: TokenParser a -> TokenParser [a] +semiList1 p + = do{ x <- p + ; do{ lexeme LexSEMI + ; xs <- semiList p + ; return (x:xs) + } + <|> return [x] + } + +semiList :: TokenParser a -> TokenParser [a] +semiList p + = semiList1 p <|> return [] + +---------------------------------------------------------------- +-- Lexeme parsers +---------------------------------------------------------------- + +customid :: TokenParser Id +customid + = varid + <|> conid + <|> parens (opid <|> conopid) + <|> do{ s <- lexString; return (idFromString s) } + "custom identifier" + +variable :: TokenParser Id +variable + = varid <|> parens opid + +opid :: TokenParser Id +opid + = identifier lexOp + "operator" + +varid :: TokenParser Id +varid + = identifier lexId + "variable" + +qualifiedVar :: TokenParser (Id, Id) +qualifiedVar + = do{ (m,name) <- lexQualifiedId + ; return (idFromString m, idFromString name) + } + +bindid :: TokenParser Id +bindid = varid {- + = do{ x <- varid + ; do{ lexeme LexEXCL + ; return x {- (setSortId SortStrict id) -} + } + <|> return x + -} + +constructor :: TokenParser Id +constructor + = conid <|> parens conopid + +conopid :: TokenParser Id +conopid + = identifier lexConOp + <|> do{ lexeme LexCOLON; return (idFromString ":") } + "constructor operator" + +conid :: TokenParser Id +conid + = identifier lexCon + "constructor" + +qualifiedCon :: TokenParser (Id, Id) +qualifiedCon + = do{ (m,name) <- lexQualifiedCon + ; return (idFromString m, idFromString name) + } + +typeid :: TokenParser Id +typeid + = identifier lexCon -- (setSortId SortType id) + "type" + +typevarid :: TokenParser Id +typevarid + = identifier lexId -- (setSortId SortType id) + +identifier :: TokenParser String -> TokenParser Id +identifier = liftM idFromString + +---------------------------------------------------------------- +-- Basic parsers +---------------------------------------------------------------- + +lexeme :: Lexeme -> TokenParser () +lexeme lex = satisfy f show lex + where + f a | a == lex = Just () + | otherwise = Nothing + + +lexChar :: TokenParser Char +lexChar + = satisfy (\lex -> case lex of { LexChar c -> Just c; _ -> Nothing }) + +lexString :: TokenParser String +lexString + = satisfy (\lex -> case lex of { LexString s -> Just s; _ -> Nothing }) + +lexDouble :: TokenParser Double +lexDouble + = satisfy (\lex -> case lex of { LexFloat d -> Just d; _ -> Nothing }) + +lexInt :: TokenParser Integer +lexInt + = satisfy (\lex -> case lex of { LexInt i -> Just i; _ -> Nothing }) + +lexId :: TokenParser String +lexId + = satisfy (\lex -> case lex of { LexId s -> Just s; _ -> Nothing }) + +lexQualifiedId :: TokenParser (String, String) +lexQualifiedId + = satisfy (\lex -> case lex of { LexQualId m x -> Just (m,x); _ -> Nothing }) + +lexOp :: TokenParser String +lexOp + = satisfy (\lex -> case lex of { LexOp s -> Just s; _ -> Nothing }) + +lexCon :: TokenParser String +lexCon + = satisfy (\lex -> case lex of { LexCon s -> Just s; _ -> Nothing }) + +lexQualifiedCon :: TokenParser (String, String) +lexQualifiedCon + = satisfy (\lex -> case lex of { LexQualCon m x -> Just (m,x); _ -> Nothing }) + +lexConOp :: TokenParser String +lexConOp + = satisfy (\lex -> case lex of { LexConOp s -> Just s; _ -> Nothing }) + +satisfy :: (Lexeme -> Maybe a) -> TokenParser a +satisfy p + = tokenPrim showtok nextpos (\(_,lex) -> p lex) + where + showtok (_,lex) = show lex + nextpos pos _ (((line,col),_):_) + = setSourceColumn (setSourceLine pos line) col + nextpos pos _ [] + = pos diff --git a/Lvm/Core/Parsing/Token.hs b/Lvm/Core/Parsing/Token.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Parsing/Token.hs @@ -0,0 +1,109 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Lexer.hs 269 2012-08-31 15:16:49Z bastiaan $ + +module Lvm.Core.Parsing.Token + ( Token, Lexeme(..), Pos, incpos, newpos + ) where + +import Text.PrettyPrint.Leijen (Pretty(..)) + +----------------------------------------------------------- +-- Tokens and lexems +----------------------------------------------------------- + +type Pos = (Int,Int) +type Token = (Pos,Lexeme) + +data Lexeme = LexUnknown Char + | LexError String + | LexChar Char + | LexString String + | LexInt Integer + | LexFloat Double + | LexId String + | LexQualId String String + | LexOp String + | LexCon String + | LexQualCon String String + | LexConOp String + + | LexCOMMA -- , + | LexQUOTE -- ` + | LexSEMI -- ; + | LexBSLASH -- \ (niet meteen een enter hierachter vanwege -cpp) + | LexASG -- = + | LexCOLON -- : + | LexCOLCOL -- :: + | LexDOT -- . + | LexDOTDOT -- .. + | LexBAR -- | + | LexLARROW -- <- + | LexRARROW -- -> + | LexTILDE -- ~ + | LexARROW -- => + | LexAT -- @ + | LexEXCL -- ! + | LexDASH -- - + + | LexLPAREN -- ( + | LexRPAREN -- ) + | LexLBRACKET -- [ + | LexRBRACKET -- ] + | LexLBRACE -- { + | LexRBRACE -- } + + | LexLET + | LexIN + | LexDO + | LexWHERE + | LexCASE + | LexOF + | LexIF + | LexTHEN + | LexELSE + | LexDATA + | LexTYPE + | LexMODULE + | LexIMPORT + | LexEOF + + -- not standard + | LexLETSTRICT + | LexMATCH + | LexWITH + + | LexPRIVATE + | LexPUBLIC + | LexDEFAULT + | LexCON + + | LexABSTRACT + | LexINSTR + | LexEXTERN + + | LexNOTHING + | LexCUSTOM + + | LexSTATIC | LexDYNAMIC | LexRUNTIME + | LexCCALL | LexSTDCALL | LexINSTRCALL + | LexDECORATE | LexORDINAL + deriving (Eq,Show) + +instance Pretty Lexeme where + pretty = pretty . show + +----------------------------------------------------------- +-- Positions +----------------------------------------------------------- + +incpos :: Pos -> Int -> Pos +incpos (line,col) i = (line,col+i) + +newpos :: Pos -> Char -> Pos +newpos (line,_) '\n' = (line + 1,1) +newpos (line,col) '\t' = (line, ((((col-1) `div` 8)+1)*8)+1) +newpos (line,col) _ = (line, col+1) diff --git a/Lvm/Core/PrettyId.hs b/Lvm/Core/PrettyId.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/PrettyId.hs @@ -0,0 +1,94 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: PrettyId.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.PrettyId + ( ppId, ppVarId, ppConId, ppQualId + , ppQualCon, ppString + ) where + +import Data.Char +import Lvm.Common.Id +import Lvm.Common.IdSet +import Text.PrettyPrint.Leijen + +ppId :: Id -> Doc +ppId = ppEscapeId isAlpha quoted + +ppVarId :: Id -> Doc +ppVarId = ppEscapeId isLower quoted + +ppConId :: Id -> Doc +ppConId = ppEscapeId isUpper (quoted . (':' :)) + +ppQualId :: Id -> Id -> Doc +ppQualId x y = pretty x <> dot <> ppVarId y + +ppQualCon :: Id -> Id -> Doc +ppQualCon x y = pretty x <> dot <> ppConId y + +quoted :: String -> String +quoted s = "''" ++ s ++ "''" + +ppString :: String -> Doc +ppString s + = dquotes (text (concatMap escape s)) + +ppEscapeId :: (Char -> Bool) -> (String -> String) -> Id -> Doc +ppEscapeId isValid esc x + = if not (isReserved x) && firstOk && ordinary + then text name + else text (esc (concatMap escapeId name)) <> char ' ' + where + name = stringFromId x + firstOk = case name of + [] -> False + y:_ -> isValid y + ordinary = all idchar name + +idchar :: Char -> Bool +idchar c = isAlphaNum c || c == '_' || c == '\'' + +escapeId :: Char -> String +escapeId ' ' = "\\s" +escapeId c = escape c + +escape :: Char -> String +escape c + = case c of + -- '.' -> "\\." + '\a' -> "\\a" + '\b' -> "\\b" + '\f' -> "\\f" + '\n' -> "\\n" + '\r' -> "\\r" + '\t' -> "\\t" + '\v' -> "\\v" + '\\' -> "\\\\" + '\"' -> "\\\"" + '\'' -> "\\'" + _ -> [c] + + +isReserved :: Id -> Bool +isReserved = (`elemSet` reserved) + +reserved :: IdSet +reserved + = setFromList $ map idFromString + ["module","where" + ,"import","abstract","extern" + ,"custom","val","con" + ,"match","with" + ,"let","rec","in" + ,"static","dynamic","runtime" + ,"stdcall","ccall","instruction" + ,"decorate" + ,"private","public","nothing" + ,"type","data","forall","exist" + ,"case","of" + ,"if","then","else" + ] diff --git a/Lvm/Core/RemoveDead.hs b/Lvm/Core/RemoveDead.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/RemoveDead.hs @@ -0,0 +1,147 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: RemoveDead.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.RemoveDead (coreRemoveDead) where + +import qualified Data.Set as Set +import Data.Set (Set) +import Lvm.Common.Id +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.FreeVar +import Lvm.Core.Utils +import Data.List + +---------------------------------------------------------------- +-- The identity of a declaration is it's name *and* the kind. +-- i.e. we can have a kind Type and a type Type. Extern declarations +-- are identified as Value declarations since they are not +-- distinguished from normal values inside core expressions. +---------------------------------------------------------------- +type Identity = (DeclKind,Id) +type Used = Set Identity + +declIdentity :: CoreDecl -> Identity +declIdentity decl@(DeclExtern {}) + = (DeclKindValue, declName decl) +declIdentity decl + = (declKindFromDecl decl, declName decl) + + + +---------------------------------------------------------------- +-- Remove all dead declarations +-- TODO: at the moment, the analysis is too conservative and +-- only removes private declarations that are nowhere used. +-- A proper analysis would find all reachable declaratins. +---------------------------------------------------------------- +coreRemoveDead :: CoreModule -> CoreModule +coreRemoveDead m + = m { moduleDecls = filter (isUsed used) (moduleDecls m) } + where + -- Retain main$ even though it is private and not used + -- It cannot be public because it would be imported and clash + -- in other modules + used = foldl' usageDecl alwaysUsed (moduleDecls m) + + alwaysUsed = Set.fromList + [ (DeclKindValue, idFromString "main$") + , (DeclKindValue, idFromString "main") + ] + +---------------------------------------------------------------- +-- Is a declaration used? +---------------------------------------------------------------- +isUsed :: Used -> CoreDecl -> Bool +isUsed used decl + = accessPublic (declAccess decl) || Set.member (declIdentity decl) used + + +---------------------------------------------------------------- +-- Find used declarations +---------------------------------------------------------------- +usageDecl :: Used -> CoreDecl -> Used +usageDecl used decl + = let usedCustoms = usageCustoms used (declCustoms decl) + in case decl of + DeclValue{} -> let usedExpr = usageValue usedCustoms (valueValue decl) + usedEnc = case valueEnc decl of + Just x -> Set.insert (DeclKindValue,x) usedExpr + Nothing -> usedExpr + in usedEnc + _ -> usedCustoms + +usageCustoms :: Used -> [Custom] -> Used +usageCustoms = foldl' usageCustom + +usageCustom :: Set (DeclKind, Id) -> Custom -> Set (DeclKind, Id) +usageCustom used custom + = case custom of + CustomLink x kind -> Set.insert (kind,x) used + CustomDecl _ customs -> usageCustoms used customs + _ -> used + +---------------------------------------------------------------- +-- Find used declarations in expressions +---------------------------------------------------------------- + +usageValue :: Used -> Expr -> Used +usageValue = usageExpr emptySet + +usageExprs :: IdSet -> Used -> [Expr] -> Used +usageExprs = foldl' . usageExpr + +usageExpr :: IdSet -> Used -> Expr -> Used +usageExpr locals used expr + = case expr of + Let binds e -> let used' = usageBinds locals used binds + locals' = unionSet locals (binder binds) + in usageExpr locals' used' e + Lam x e -> usageExpr (insertSet x locals) used e + Match x alts -> usageAlts locals (usageVar locals used x) alts + Ap e1 e2 -> usageExpr locals (usageExpr locals used e1) e2 + Var x -> usageVar locals used x + Con con -> usageCon locals used con + Lit _ -> used + +usageVar :: IdSet -> Set (DeclKind, Id) -> Id -> Set (DeclKind, Id) +usageVar locals used x + | elemSet x locals = used + | otherwise = Set.insert (DeclKindValue,x) used + +usageCon :: IdSet -> Set (DeclKind, Id) -> Con Expr -> Set (DeclKind, Id) +usageCon locals used con + = case con of + ConId x -> Set.insert (DeclKindCon,x) used + ConTag tag _ -> usageExpr locals used tag + +usageBinds :: IdSet -> Used -> Binds -> Used +usageBinds locals used binds + = case binds of + NonRec (Bind _ rhs) -> usageExpr locals used rhs + Strict (Bind _ rhs) -> usageExpr locals used rhs + Rec bs -> let (ids,rhss) = unzipBinds bs + locals' = unionSet locals (setFromList ids) + in usageExprs locals' used rhss + + +usageAlts :: IdSet -> Set (DeclKind, Id) -> [Alt] -> Set (DeclKind, Id) +usageAlts = foldl' . usageAlt + +usageAlt :: IdSet -> Set (DeclKind, Id) -> Alt -> Used +usageAlt locals used (Alt pat expr) + = case pat of + PatCon con ids -> let locals' = unionSet locals (setFromList ids) + used' = usageConPat used con + in usageExpr locals' used' expr + _ -> usageExpr locals used expr + +usageConPat :: Set (DeclKind, Id) -> Con t -> Set (DeclKind, Id) +usageConPat used con + = case con of + ConId x -> Set.insert (DeclKindCon,x) used + ConTag _ _ -> used diff --git a/Lvm/Core/Saturate.hs b/Lvm/Core/Saturate.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Saturate.hs @@ -0,0 +1,110 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Saturate.hs 291 2012-11-08 11:27:33Z heere112 $ + +---------------------------------------------------------------- +-- saturate all calls to externals, instructions and constructors. +-- pre: [coreNoShadow] +---------------------------------------------------------------- +module Lvm.Core.Saturate (coreSaturate) where + +import Data.List +import Data.Maybe +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Core.Expr +import Lvm.Core.Utils + +---------------------------------------------------------------- +-- Environment: a name supply and a map from id to its arity +---------------------------------------------------------------- +data Env = Env NameSupply (IdMap Int) + +uniqueId :: Env -> (Id, Env) +uniqueId (Env supply arities) + = let (x,supply') = freshId supply + in (x,Env supply' arities) + +findArity :: Id -> Env -> Int +findArity x (Env _ arities) + = fromMaybe 0 (lookupMap x arities) + +splitEnv :: Env -> (Env, Env) +splitEnv (Env supply arities) + = let (s0,s1) = splitNameSupply supply + in (Env s0 arities, Env s1 arities) + +splitEnvs :: Env -> [Env] +splitEnvs (Env supply arities) + = map (`Env` arities) (splitNameSupplies supply) + +---------------------------------------------------------------- +-- coreSaturate +---------------------------------------------------------------- +coreSaturate :: NameSupply -> CoreModule -> CoreModule +coreSaturate supply m + = mapExprWithSupply (satDeclExpr arities) supply m + where + arities = mapFromList [(declName d,declArity d) | d <- moduleDecls m, isDeclCon d || isDeclExtern d] + + +satDeclExpr :: IdMap Int -> NameSupply -> Expr -> Expr +satDeclExpr arities supply = satExpr (Env supply arities) + +---------------------------------------------------------------- +-- saturate expressions +---------------------------------------------------------------- +satExpr :: Env -> Expr -> Expr +satExpr env expr + = case expr of + Let binds e + -> let (env0,env1) = splitEnv env + in Let (satBinds env0 binds) (satExpr env1 e) + Match x alts + -> Match x (satAlts env alts) + Lam x e + -> Lam x (satExpr env e) + _ + -> let expr' = satExprSimple env expr + in addLam env (requiredArgs env expr') expr' + +satBinds :: Env -> Binds -> Binds +satBinds = zipBindsWith (\env x expr -> Bind x (satExpr env expr)) . splitEnvs + +satAlts :: Env -> Alts -> Alts +satAlts = zipAltsWith (\env pat expr -> Alt pat (satExpr env expr)) . splitEnvs + +-- don't saturate Ap, Var and Con here +satExprSimple :: Env -> Expr -> Expr +satExprSimple env expr + = case expr of + Let _ _ -> satExpr env expr + Match _ _ -> satExpr env expr + Lam _ _ -> satExpr env expr + Ap e1 e2 -> let (env1,env2) = splitEnv env + in Ap (satExprSimple env1 e1) (satExpr env2 e2) + _ -> expr + +---------------------------------------------------------------- +-- Add lambda's +---------------------------------------------------------------- + +addLam :: (Num a, Enum a) => Env -> a -> Expr -> Expr +addLam env n expr + = let (_,ids) = mapAccumR (\env2 _ -> let (x,env') = uniqueId env2 in (env',x)) env [1..n] + in foldr Lam (foldl Ap expr (map Var ids)) ids + +requiredArgs :: Env -> Expr -> Int +requiredArgs env expr + = case expr of + Let _ _ -> 0 + Match _ _ -> 0 + Lam _ _ -> 0 + Ap e1 _ -> requiredArgs env e1 - 1 + Var x -> findArity x env + Con (ConId x) -> findArity x env + Con (ConTag _ arity) -> arity + _ -> 0 diff --git a/Lvm/Core/ToAsm.hs b/Lvm/Core/ToAsm.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/ToAsm.hs @@ -0,0 +1,187 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: ToAsm.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Core.ToAsm (coreToAsm) where + +import Control.Exception (assert) +import Lvm.Common.Id +import Lvm.Common.IdSet +import Lvm.Core.Expr +import Lvm.Core.Utils +import qualified Lvm.Asm.Data as Asm + +import Lvm.Core.NoShadow (coreRename) -- rename local variables +import Lvm.Core.Saturate (coreSaturate) -- saturate constructors, instructions and externs +import Lvm.Core.Normalize (coreNormalize) -- normalize core, ie. atomic arguments and lambda's at let bindings +import Lvm.Core.LetSort (coreLetSort) -- find smallest recursive let binding groups +import Lvm.Core.Lift (coreLift) -- lambda-lift, ie. make free variables arguments + +{--------------------------------------------------------------- + coreToAsm: translate Core expressions into Asm expressions +---------------------------------------------------------------} +coreToAsm :: NameSupply -> CoreModule -> Asm.AsmModule +coreToAsm supply + = exprToTop + . coreLift + . coreLetSort + . coreNormalize supply2 + . coreSaturate supply1 + . coreRename supply0 + where + (supply0:supply1:supply2:_) = splitNameSupplies supply + +exprToTop :: CoreModule -> Asm.AsmModule +exprToTop m + = m{ moduleDecls = concatMap (asmDecl (externNames m)) (moduleDecls m) } + +{--------------------------------------------------------------- + top-level bindings +---------------------------------------------------------------} + +asmDecl :: IdSet -> Decl Expr -> [Decl Asm.Top] +asmDecl prim decl = + case decl of + DeclValue x acc enc expr custom -> + let (pars,(lifted,asmexpr)) = asmTop prim expr + in DeclValue x acc enc (Asm.Top pars asmexpr) custom : concatMap (asmLifted prim (declName decl)) lifted + _ -> [fmap (error "asmDecl") decl] + +asmLifted :: IdSet -> Id -> Bind -> [Decl Asm.Top] +asmLifted prim enc (Bind x expr) + = let (pars,(lifted,asmexpr)) = asmTop prim expr + in DeclValue x (Defined False) (Just enc) (Asm.Top pars asmexpr) [] + : concatMap (asmLifted prim x) lifted + +asmTop :: IdSet -> Expr -> ([Id], ([Bind], Asm.Expr)) +asmTop prim expr + = let (pars,expr') = splitParams expr + in (pars,asmExpr prim expr') + +splitParams :: Expr -> ([Id],Expr) +splitParams expr + = case expr of + Lam x e -> let (pars,e') = splitParams e in (x:pars,e') + _ -> ([],expr) + +{--------------------------------------------------------------- + expressions +---------------------------------------------------------------} +asmExpr :: IdSet -> Expr -> ([Bind],Asm.Expr) +asmExpr prim expr + = case expr of + Let binds e -> asmLet prim binds (asmExpr prim e) + Match x alts -> let (lifted,asmalts) = asmAlts prim alts + in (concat lifted, Asm.Match x asmalts) + atom -> let asmatom = asmAtom atom [] -- handles prim ap's too + in case asmatom of + Asm.Ap x args | elemSet x prim + -> ([],Asm.Prim x args) + _ -> ([],asmatom) + +asmAlts :: IdSet -> [Alt] -> ([[Bind]], [Asm.Alt]) +asmAlts prim alts + = unzip (map (asmAlt prim) alts) + +asmAlt :: IdSet -> Alt -> ([Bind], Asm.Alt) +asmAlt prim (Alt pat expr) + = let (lifted,asmexpr) = asmExpr prim expr + in (lifted, Asm.Alt (asmPat pat) asmexpr) + +asmPat :: Pat -> Asm.Pat +asmPat pat + = case pat of + PatCon con params -> Asm.PatCon (asmPatCon con) params + PatLit lit -> Asm.PatLit (asmLit lit) + PatDefault -> Asm.PatVar (idFromString ".def") + +asmPatCon :: Con a -> Asm.Con a +asmPatCon con + = case con of + ConId x -> Asm.ConId x + ConTag tag arity -> Asm.ConTag tag arity + +asmLet :: IdSet -> Binds -> ([Bind], Asm.Expr) -> ([Bind], Asm.Expr) +asmLet prim binds (lifted,asmexpr) + = case binds of + NonRec (Bind x expr) + -> if isAtomic prim expr + then (lifted, Asm.Let x (asmAtom expr []) asmexpr) + else (Bind x expr:lifted,asmexpr) + Strict (Bind x rhs) + -> let (liftedrhs,asmrhs) = asmExpr prim rhs + in (lifted ++ liftedrhs,Asm.Eval x asmrhs asmexpr) + Rec bs -> let (lifted',binds') = foldr asmRec (lifted,[]) bs + in if null binds' + then (lifted',asmexpr) + else (lifted',Asm.LetRec binds' asmexpr) + where + asmRec bind@(Bind x expr) (lft,bs) + | isAtomic prim expr = (lft,(x,asmAtom expr []):bs) + | otherwise = (bind:lft,bs) + + +{--------------------------------------------------------------- + atomic expressions & primitive applications +---------------------------------------------------------------} + +asmAtom :: Expr -> [Asm.Expr] -> Asm.Expr +asmAtom atom args + = case atom of + Ap e1 e2 -> asmAtom e1 (asmAtom e2 []:args) + Var x -> Asm.Ap x args + Con con -> Asm.Con (asmCon con) args + Lit lit | null args -> Asm.Lit (asmLit lit) + Let binds expr + -> asmAtomBinds binds (asmAtom expr args) + _ -> error "CoreToAsm.asmAtom: non atomic expression (do 'coreNormalise' first?)" + +asmCon :: Con Expr -> Asm.Con Asm.Atom +asmCon con + = case con of + ConId x -> Asm.ConId x + ConTag tag arity -> assert (simpleTag tag) $ -- "CoreToAsm.asmCon: tag expression too complex (should be integer or (strict) variable" + Asm.ConTag (asmAtom tag []) arity + where + simpleTag (Lit (LitInt _)) = True + simpleTag (Var _) = True + simpleTag _ = False + +asmAtomBinds :: Binds -> Asm.Expr -> Asm.Expr +asmAtomBinds binds + = case binds of + NonRec (Bind x expr) -> Asm.Let x (asmAtom expr []) + Rec bs -> Asm.LetRec [(x,asmAtom expr []) | Bind x expr <- bs] + _ -> error "CoreToAsm.asmAtomBinds: strict binding as atomic expression (do 'coreNormalise first?)" + +asmLit :: Literal -> Asm.Lit +asmLit lit + = case lit of + LitInt i -> Asm.LitInt i + LitDouble d -> Asm.LitFloat d + LitBytes s -> Asm.LitBytes s + +{--------------------------------------------------------------- + is an expression atomic ? +---------------------------------------------------------------} + +isAtomic :: IdSet -> Expr -> Bool +isAtomic prim expr + = case expr of + Ap e1 e2 -> isAtomic prim e1 && isAtomic prim e2 + Var x -> not (elemSet x prim) + Con (ConId _) -> True + Con (ConTag t _) -> isAtomic prim t + Lit _ -> True + Let binds e + -> isAtomicBinds prim binds && isAtomic prim e + _ -> False + +isAtomicBinds :: IdSet -> Binds -> Bool +isAtomicBinds prim binds + = case binds of + Strict _ -> False + _ -> all (isAtomic prim) (snd (unzipBinds (listFromBinds binds))) diff --git a/Lvm/Core/Type.hs b/Lvm/Core/Type.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Type.hs @@ -0,0 +1,146 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 250 2012-08-22 10:59:40Z bastiaan $ + +module Lvm.Core.Type + ( Type(..), Kind(..) + , addForall, arityFromType + ) where + +import Lvm.Common.Id +import Lvm.Common.IdSet +import Text.PrettyPrint.Leijen + +---------------------------------------------------------------- +-- Types +---------------------------------------------------------------- +data Type = TFun Type Type + | TAp Type Type + | TForall Id Type + | TExist Id Type + | TStrict Type + | TVar Id + | TCon Id + | TAny + | TString String + +data Kind = KFun {kind1::Kind, kind2::Kind} + | KStar + | KString {kindString::String} + +-- data SuperKind = Box + +arityFromType :: Type -> Int +arityFromType tp + = case tp of + TFun _ t2 -> arityFromType t2 + 1 + TAp _ _ -> 0 -- assumes saturated constructors! + TForall _ t -> arityFromType t + TExist _ t -> arityFromType t + TStrict t -> arityFromType t + TVar _ -> 0 + TCon _ -> 0 + TAny -> 0 + TString _ -> error "Core.arityFromType: string type" + +{- +arityFromKind :: Kind -> Int +arityFromKind kind + = case kind of + KFun k1 _ -> arityFromKind k1 + 1 + KStar -> 0 + KString _ -> error "Core.arityFromKind: string kind" -} + +addForall :: Type -> Type +addForall tp + = foldr TForall tp (listFromSet (varsInType tp)) + +varsInType :: Type -> IdSet +varsInType tp + = case tp of + TForall a t -> deleteSet a (varsInType t) + TExist a t -> deleteSet a (varsInType t) + TString _ -> emptySet + TFun t1 t2 -> unionSet (varsInType t1) (varsInType t2) + TAp t1 t2 -> unionSet (varsInType t1) (varsInType t2) + TStrict t -> varsInType t + TVar a -> singleSet a + TCon _ -> emptySet + TAny -> emptySet + +---------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------- + +instance Show Type where + show = show . pretty + +instance Show Kind where + show = show . pretty + +instance Pretty Type where + pretty = ppType 0 + +instance Pretty Kind where + pretty = ppKind 0 + +ppType :: Int -> Type -> Doc +ppType level tp + = parenthesized $ + case tp of + TAp (TCon a) t2 | a == idFromString "[]" -> text "[" <> pretty t2 <> text "]" + TFun t1 t2 -> ppHi t1 <+> text "->" <+> ppEq t2 + TAp t1 t2 -> ppEq t1 <+> ppHi t2 + TForall a t -> text "forall" <+> pretty a <> text "." <+> ppEq t + TExist a t -> text "exist" <+> pretty a <> text "." <+> ppEq t + TStrict t -> ppHi t <> text "!" + TVar a -> pretty a + TCon a -> pretty a + TAny -> text "any" + TString s -> string s + where + tplevel = levelFromType tp + parenthesized doc | level <= tplevel = doc + | otherwise = parens doc + ppHi t | level <= tplevel = ppType (tplevel+1) t + | otherwise = ppType 0 t + ppEq t | level <= tplevel = ppType tplevel t + | otherwise = ppType 0 t + +ppKind :: Int -> Kind -> Doc +ppKind level kind + = parenthesized $ + case kind of + KFun k1 k2 -> ppHi k1 <+> text "->" <+> ppEq k2 + KStar -> text "*" + KString s -> string s + where + (klevel,parenthesized) + | level <= levelFromKind kind = (levelFromKind kind,id) + | otherwise = (0,parens) + + ppHi = ppKind (if klevel<=0 then 0 else klevel+1) + ppEq = ppKind klevel + +levelFromType :: Type -> Int +levelFromType tp + = case tp of + TString{} -> 1 + TForall{} -> 2 + TExist{} -> 2 + TFun{} -> 3 + TAp{} -> 4 + TStrict{} -> 5 + TVar{} -> 6 + TCon{} -> 6 + TAny -> 7 + +levelFromKind :: Kind -> Int +levelFromKind kind + = case kind of + KString{} -> 1 + KFun{} -> 2 + KStar{} -> 3 diff --git a/Lvm/Core/Utils.hs b/Lvm/Core/Utils.hs new file mode 100644 --- /dev/null +++ b/Lvm/Core/Utils.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 250 2012-08-22 10:59:40Z bastiaan $ + +module Lvm.Core.Utils + ( module Lvm.Core.Module + , listFromBinds, unzipBinds, mapBinds, mapAccumBinds, zipBindsWith + , mapAlts, zipAltsWith, mapExprWithSupply, mapAccum + ) where + +import Lvm.Core.Expr +import Lvm.Common.Id +import Lvm.Core.Module + +---------------------------------------------------------------- +-- Binders functions +---------------------------------------------------------------- + +listFromBinds :: Binds -> [Bind] +listFromBinds binds + = case binds of + NonRec bind -> [bind] + Strict bind -> [bind] + Rec recs -> recs + +unzipBinds :: [Bind] -> ([Id],[Expr]) +unzipBinds = unzip . map (\(Bind x rhs) -> (x,rhs)) + +mapBinds :: (Id -> Expr -> Bind) -> Binds -> Binds +mapBinds f binds + = case binds of + NonRec (Bind x rhs) + -> NonRec (f x rhs) + Strict (Bind x rhs) + -> Strict (f x rhs) + Rec recs + -> Rec (map (\(Bind x rhs) -> f x rhs) recs) + +mapAccumBinds :: (a -> Id -> Expr -> (Bind,a)) -> a -> Binds -> (Binds,a) +mapAccumBinds f x binds + = case binds of + NonRec (Bind y rhs) + -> let (bind,z) = f x y rhs + in (NonRec bind, z) + Strict (Bind y rhs) + -> let (bind,z) = f x y rhs + in (Strict bind, z) + Rec recs + -> let (recs',z) = mapAccum (\a (Bind y rhs) -> f a y rhs) x recs + in (Rec recs',z) + +mapAccum :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a) +mapAccum _ s [] = ([],s) +mapAccum f s (x:xs) = (y:ys,s'') + where (y,s' ) = f s x + (ys,s'') = mapAccum f s' xs + + +zipBindsWith :: (a -> Id -> Expr -> Bind) -> [a] -> Binds -> Binds +zipBindsWith f (x:_) (Strict (Bind y rhs)) + = Strict (f x y rhs) +zipBindsWith f (x:_) (NonRec (Bind y rhs)) + = NonRec (f x y rhs) +zipBindsWith f xs (Rec recs) + = Rec (zipWith (\x (Bind y rhs) -> f x y rhs) xs recs) +zipBindsWith _ _ _ + = error "zipBindsWith" + +---------------------------------------------------------------- +-- Alternatives functions +---------------------------------------------------------------- + +mapAlts :: (Pat -> Expr -> Alt) -> Alts -> Alts +mapAlts f = map (\(Alt pat expr) -> f pat expr) + +zipAltsWith :: (a -> Pat -> Expr -> Alt) -> [a] -> Alts -> Alts +zipAltsWith f = zipWith (\x (Alt pat expr) -> f x pat expr) + +---------------------------------------------------------------- +-- +---------------------------------------------------------------- + +mapExprWithSupply :: (NameSupply -> Expr -> Expr) -> NameSupply -> CoreModule -> CoreModule +mapExprWithSupply f supply m + = m { moduleDecls = mapWithSupply fvalue supply (moduleDecls m) } + where + fvalue sup decl@(DeclValue{}) = decl{ valueValue = f sup (valueValue decl)} + fvalue _ decl = decl diff --git a/Lvm/Data.hs b/Lvm/Data.hs new file mode 100644 --- /dev/null +++ b/Lvm/Data.hs @@ -0,0 +1,28 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Data + ( module Lvm.Core.Module, LvmModule, LvmDecl + -- constants + , recHeader,recFooter + ) where + +import Lvm.Core.Module +import Lvm.Instr.Data ( Instr ) + +{-------------------------------------------------------------- + An LVM module +---------------------------------------------------------------} +type LvmModule = Module [Instr] +type LvmDecl = Decl [Instr] + +{--------------------------------------------------------------- + Constants +---------------------------------------------------------------} +recHeader,recFooter :: Int +recHeader = 0x1F4C564D +recFooter = 0x1E4C564D diff --git a/Lvm/Import.hs b/Lvm/Import.hs new file mode 100644 --- /dev/null +++ b/Lvm/Import.hs @@ -0,0 +1,138 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Import.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Import (lvmImport, lvmImportDecls) where + +import Control.Monad +import Data.List +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Data +import Lvm.Read (lvmReadFile) +import qualified Lvm.Core.Module as Module + +{-------------------------------------------------------------- + lvmImport: replace all import declarations with + abstract declarations or constructors/externs/customs +--------------------------------------------------------------} +lvmImport :: (Id -> IO FilePath) -> Module v -> IO (Module v) +lvmImport findModule m + = do{ mods <- lvmImportModules findModule m + ; let mods0 = lvmExpandModule mods (moduleName m) + mods1 = lvmResolveImports mods0 + mod1 = findMap (moduleName m) mods1 + ; return mod1{ moduleDecls = filter (not . isDeclImport) (moduleDecls mod1) } + } + +lvmImportDecls :: (Id -> IO FilePath) -> [Decl v] -> IO [[Decl v]] +lvmImportDecls findModule = mapM $ \importDecl -> do + m <- lvmImport findModule + Module.Module + { Module.moduleName = idFromString "Main" + , Module.moduleMajorVer = 0 + , Module.moduleMinorVer = 0 + , Module.moduleDecls = [importDecl] + } + return (moduleDecls m) + +{-------------------------------------------------------------- + lvmImportModules: + recursively read all imported modules +--------------------------------------------------------------} +lvmImportModules :: (Id -> IO FilePath) -> Module v -> IO (IdMap (Module v)) +lvmImportModules findModule m + = readModuleImports findModule emptyMap (moduleName m) m + +readModuleImports :: (Id -> IO FilePath) -> IdMap (Module v) -> Id -> Module v -> IO (IdMap (Module v)) +readModuleImports findModule loaded x m + = foldM (readModule findModule) (insertMap x m loaded) (imported m) + +readModule :: (Id -> IO FilePath) -> IdMap (Module v) -> Id -> IO (IdMap (Module v)) +readModule findModule loaded x + | elemMap x loaded = return loaded + | otherwise = do{ fname <- findModule x + ; m <- lvmReadFile fname + ; readModuleImports findModule loaded x (filterPublic m) + } + +imported :: Module v -> [Id] +imported m = [importModule (declAccess d) | d <- moduleDecls m, isDeclImport d] + +{-------------------------------------------------------------- + lvmExpandModule loaded modname: + expand Module import declarations of [modname] + into declarations for all items exported from that module. +--------------------------------------------------------------} +lvmExpandModule :: IdMap (Module v) -> Id -> IdMap (Module v) +lvmExpandModule loaded modname + = mapMap expand loaded + where + expand m | moduleName m == modname = expandModule loaded m + | otherwise = m + +expandModule :: IdMap (Module v) -> Module v -> Module v +expandModule loaded m + = m{ moduleDecls = concatMap (expandDecl loaded (moduleName m)) (moduleDecls m) } + +expandDecl :: IdMap (Module a) -> Id -> Decl a -> [Decl a] +expandDecl loaded modname DeclImport{declAccess = access@(Imported{importModule = imodname,importKind = DeclKindModule})} + = case lookupMap imodname loaded of + Nothing -> error ("LvmImport.expandDecl: import module is not loaded: " ++ stringFromId modname) + Just imod | moduleName imod == modname + -> error ("LvmImport.expandDecl: module imports itself: " ++ stringFromId modname) + Just imod -> map importDecl (moduleDecls imod) + where + importDecl decl + = decl{ declAccess = access{importName = declName decl, importKind = declKindFromDecl decl} } + +expandDecl _ _ decl = [decl] + +{--------------------------------------------------------------- +lvmResolveImports: + replaces all "DImport" declarations with the real + declaration (except the access is Import). This is always + needed for all modules. +---------------------------------------------------------------} +lvmResolveImports :: IdMap (Module v) -> IdMap (Module v) +lvmResolveImports mods = foldl' resolveImports mods (listFromMap mods) + +resolveImports :: IdMap (Module v) -> (Id,Module v) -> IdMap (Module v) +resolveImports loaded (modid, m) + = foldl' (resolveImport [] modid) loaded (filter isDeclImport (moduleDecls m)) + +resolveImport :: [Id] -> Id -> IdMap (Module v) -> Decl v -> IdMap (Module v) +resolveImport visited modid loaded imp@(DeclImport x access@(Imported _ imodid impid kind _ _) _) + | modid `elem` visited = error ("LvmImport.resolveImport: circular import chain: " ++ stringFromId imodid ++ "." ++ stringFromId impid) + | otherwise = + let m = findMap modid loaded in + case lookupMap imodid loaded of + Nothing -> error ("LvmImport.resolveImport: import module is not loaded: " ++ stringFromId imodid) + Just imod -> case lookupDecl impid kind (moduleDecls imod) of + [] -> notfound imodid impid + ds -> case filter (not . isDeclImport) ds of + [] -> case filter isDeclImport ds of + [] -> notfound imodid impid + [d] -> let loaded' = resolveImport (modid:visited) imodid loaded d + in resolveImport (imodid:visited) modid loaded' imp + _ -> ambigious imodid impid + [d] -> update m { moduleDecls = d{declName=x,declAccess = access} : moduleDecls m} + _ -> ambigious imodid impid + where + update m = updateMap modid m loaded +resolveImport _ _ _ _ = error "resolveImport: not DeclImport" + +lookupDecl :: Id -> DeclKind -> [Decl a] -> [Decl a] +lookupDecl impid kind decls = + [d | d <- decls, declName d==impid && declKindFromDecl d == kind] + +notfound :: Id -> Id -> a +notfound imodid impid = + error ("LvmImport.resolveImport: unresolved identifier: " ++ stringFromId imodid ++ "." ++ stringFromId impid) + +ambigious :: Id -> Id -> a +ambigious imodid impid = + error ("LvmImport.resolveImport: ambigious import record: " ++ stringFromId imodid ++ "." ++ stringFromId impid) diff --git a/Lvm/Instr/Data.hs b/Lvm/Instr/Data.hs new file mode 100644 --- /dev/null +++ b/Lvm/Instr/Data.hs @@ -0,0 +1,724 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Data.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Instr.Data + ( Instr(..), Var(..), Con(..), Global(..), Alt(..), Pat(..) + , Offset, Depth, Index, Tag, Arity + , opcodeFromInstr, instrFromOpcode, instrFromName, nameFromInstr + , isCATCH, strictResult + ) where + +import Data.Char +import Data.Maybe +import Lvm.Common.Byte +import Lvm.Common.Id +import Text.PrettyPrint.Leijen + +---------------------------------------------------------------- +-- Types +---------------------------------------------------------------- + +type Offset = Int +type Depth = Int +type Index = Int +type Tag = Int +type Arity = Int + +data Global = Global + { idFromGlobal :: !Id + , indexFromGlobal :: Index + , arityFromGlobal :: !Arity + } + deriving Show + +data Con = Con + { idFromCon :: !Id + , indexFromCon :: Index + , arityFromCon :: !Arity + , tagFromCon :: !Tag + } + deriving Show + +data Var = Var + { idFromVar :: !Id + , offsetFromVar :: !Offset + , depthFromVar :: !Depth + } + deriving Show + +---------------------------------------------------------------- +-- The instructions +---------------------------------------------------------------- +data Pat = PatCon !Con + | PatInt !Int + | PatTag !Tag !Arity + | PatDefault + deriving Show + +data Alt = Alt !Pat ![Instr] + deriving Show + +data Instr = + -- pseudo instructions + VAR !Id + | PARAM !Id + | USE !Id + | NOP + | ATOM ![Instr] + | INIT ![Instr] + + + -- structured instructions + | CATCH ![Instr] -- for generating PUSHCATCH + | EVAL !Depth ![Instr] -- for generating PUSHCONT + | RESULT ![Instr] -- for generating SLIDE + + | MATCH ![Alt] + | MATCHCON ![Alt] + | SWITCHCON ![Alt] + | MATCHINT ![Alt] + + -- push instructions + | PUSHVAR !Var + | PUSHINT !Int + | PUSHBYTES !Bytes !Index + | PUSHFLOAT !Double + | PUSHCODE !Global + | PUSHCONT !Offset + | PUSHCATCH + + -- stack instructions + | ARGCHK !Arity + | SLIDE !Int !Int !Depth + | STUB !Var + + -- control + | ENTER + | RAISE + | CALL !Global + + | ENTERCODE !Global + | EVALVAR !Var + + | RETURN + | RETURNCON !Con + | RETURNINT !Int + + -- applications + | ALLOCAP !Arity + | PACKAP !Var !Arity + | PACKNAP !Var !Arity + | NEWAP !Arity + | NEWNAP !Arity + + -- constructors + | ALLOCCON !Con + | PACKCON !Con !Var + | NEWCON !Con + + | ALLOC + | NEW !Arity + | PACK !Arity !Var + | UNPACK !Arity + | GETFIELD + | SETFIELD + | GETTAG + | GETSIZE + | UPDFIELD + + -- INT operations + | ADDINT + | SUBINT + | MULINT + | DIVINT + | MODINT + | QUOTINT + | REMINT + | ANDINT + | XORINT + | ORINT + | SHRINT + | SHLINT + | SHRNAT + | NEGINT + + | EQINT + | NEINT + | LTINT + | GTINT + | LEINT + | GEINT + + -- FLOAT operations + | ADDFLOAT + | SUBFLOAT + | MULFLOAT + | DIVFLOAT + | NEGFLOAT + + | EQFLOAT + | NEFLOAT + | LTFLOAT + | GTFLOAT + | LEFLOAT + | GEFLOAT + + -- optimized VAR + | PUSHVAR0 + | PUSHVAR1 + | PUSHVAR2 + | PUSHVAR3 + | PUSHVAR4 + + | PUSHVARS2 !Var !Var + + -- optimized AP + | NEWAP2 + | NEWAP3 + | NEWAP4 + + | NEWNAP2 + | NEWNAP3 + | NEWNAP4 + + -- optimized NEWCON + | NEWCON0 !Con + | NEWCON1 !Con + | NEWCON2 !Con + | NEWCON3 !Con + + | RETURNCON0 !Con + deriving Show + +---------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------- + +instance Pretty Instr where + prettyList = align . vcat . map pretty + pretty instr = + case instr of + -- pseudo instructions + VAR x -> text name <+> pretty x + PARAM x -> text name <+> pretty x + USE x -> text name <+> pretty x + NOP -> text name + + ATOM is -> nest 2 (text name <$> pretty is) + INIT is -> nest 2 (text name <$> pretty is) + + -- structured instructions + CATCH instrs -> nest 2 (text name <$> pretty instrs) + EVAL d instrs -> nest 2 (text name <+> pretty d <$> pretty instrs) + RESULT instrs -> nest 2 (text name <$> pretty instrs) + + SWITCHCON alts -> nest 2 (text name <$> pretty alts) + MATCHCON alts -> nest 2 (text name <$> pretty alts) + MATCHINT alts -> nest 2 (text name <$> pretty alts) + MATCH alts -> nest 2 (text name <$> pretty alts) + + + -- push instructions + PUSHVAR var -> text name <+> pretty var + PUSHINT n -> text name <+> pretty n + PUSHBYTES bs _ -> text name <+> ppBytes bs + PUSHFLOAT d -> text name <+> pretty d + PUSHCODE global -> text name <+> pretty global + PUSHCONT ofs -> text name <+> pretty ofs + + -- stack instructions + ARGCHK n -> text name <+> pretty n + SLIDE n m depth -> text name <+> pretty n <+> pretty m <+> pretty depth + STUB var -> text name <+> pretty var + + -- control + ENTER -> text name + RAISE -> text name + CALL global -> text name <+> pretty global + + ENTERCODE global -> text name <+> pretty global + EVALVAR var -> text name <+> pretty var + + RETURN -> text name + RETURNCON con -> text name <+> pretty con + RETURNINT n -> text name <+> pretty n + + -- applications + ALLOCAP arity -> text name <+> pretty arity + PACKAP var arity -> text name <+> pretty var <+> pretty arity + PACKNAP var arity -> text name <+> pretty var <+> pretty arity + NEWAP arity -> text name <+> pretty arity + NEWNAP arity -> text name <+> pretty arity + + -- constructors + ALLOCCON con -> text name <+> pretty con + PACKCON con var -> text name <+> pretty var <+> pretty con + NEWCON con -> text name <+> pretty con + + NEW arity -> text name <+> pretty arity + PACK arity var -> text name <+> pretty arity <+> pretty var + UNPACK arity -> text name <+> pretty arity + + -- optimized instructions + PUSHVARS2 v w -> text name <+> pretty v <+> pretty w + + NEWCON0 con -> text name <+> pretty con + NEWCON1 con -> text name <+> pretty con + NEWCON2 con -> text name <+> pretty con + NEWCON3 con -> text name <+> pretty con + + RETURNCON0 con -> text name <+> pretty con + + -- others + _ -> text name + where + name = nameFromInstr instr + +instance Pretty Alt where + pretty (Alt pat is) = nest 2 (pretty pat <> text ":" <$> pretty is) + prettyList = vcat . map pretty + +instance Pretty Pat where + pretty pat = + case pat of + PatCon con -> pretty con + PatInt i -> pretty i + PatTag t a -> text "(@" <> pretty t <> char ',' <> pretty a <> text ")" + PatDefault -> text "" + +instance Pretty Con where + pretty (Con x _ arity _) = + pretty x <+> pretty arity + +instance Pretty Global where + pretty (Global x _ arity) = + pretty x <+> pretty arity + +instance Pretty Var where + pretty (Var x ofs depth) = + pretty x <+> parens( pretty ofs <> comma <+> pretty depth ) + +ppBytes :: Bytes -> Doc +ppBytes = dquotes . string . stringFromBytes + +---------------------------------------------------------------- +-- Instruction instances +---------------------------------------------------------------- +instance Enum Instr where + fromEnum = enumFromInstr + toEnum _ = error "Code.toEnum: undefined for instructions" + +instance Eq Instr where + instr1 == instr2 = fromEnum instr1 == fromEnum instr2 + +instance Ord Instr where + compare instr1 instr2 = compare (fromEnum instr1) (fromEnum instr2) + +---------------------------------------------------------------- +-- Instruction names +---------------------------------------------------------------- +instrFromName :: String -> Instr +instrFromName name + = fromMaybe (error msg) (lookup (map toUpper name) instrNames) + where + msg = "Code.instrFromName: unknown instruction name: " ++ name + instrNames + = [ ("CATCH", CATCH []) + , ("RAISE", RAISE) + + , ("ADDINT", ADDINT) + , ("SUBINT", SUBINT) + , ("MULINT", MULINT) + , ("DIVINT", DIVINT) + , ("MODINT", MODINT) + , ("QUOTINT",QUOTINT) + , ("REMINT", REMINT) + , ("ANDINT", ANDINT) + , ("XORINT", XORINT) + , ("ORINT", ORINT) + , ("SHRINT", SHRINT) + , ("SHLINT", SHLINT) + , ("SHRNAT", SHRNAT) + , ("NEGINT", NEGINT) + + , ("EQINT", EQINT) + , ("NEINT", NEINT) + , ("LTINT", LTINT) + , ("GTINT", GTINT) + , ("LEINT", LEINT) + , ("GEINT", GEINT) + + , ("ADDFLOAT", ADDFLOAT) + , ("SUBFLOAT", SUBFLOAT) + , ("MULFLOAT", MULFLOAT) + , ("DIVFLOAT", DIVFLOAT) + , ("NEGFLOAT", NEGFLOAT) + + , ("EQFLOAT", EQFLOAT) + , ("NEFLOAT", NEFLOAT) + , ("LTFLOAT", LTFLOAT) + , ("GTFLOAT", GTFLOAT) + , ("LEFLOAT", LEFLOAT) + , ("GEFLOAT", GEFLOAT) + + , ("ALLOC", ALLOC) + , ("GETFIELD",GETFIELD) + , ("SETFIELD",SETFIELD) + , ("GETTAG", GETTAG) + , ("GETSIZE", GETSIZE) + , ("UPDFIELD",UPDFIELD) + ] + + +{--------------------------------------------------------------- + instrHasStrictResult: returns [True] if an instruction returns + a strict result, ie. a value that can be [match]ed or [RETURN]'ed. +---------------------------------------------------------------} + +strictResult :: Instr -> Bool +strictResult (NEW _) = True +strictResult instr = instr `elem` strictList + where + strictList = + [ ALLOC, ADDINT, SUBINT, MULINT, DIVINT, MODINT, QUOTINT + , REMINT, ANDINT, XORINT, ORINT, SHRINT, SHLINT, SHRNAT + , NEGINT, EQINT, NEINT, LTINT, GTINT, LEINT, GEINT + , ADDFLOAT, SUBFLOAT, MULFLOAT, DIVFLOAT, NEGFLOAT + , EQFLOAT, NEFLOAT, LTFLOAT, GTFLOAT, LEFLOAT, GEFLOAT + ] + +---------------------------------------------------------------- +-- Instruction opcodes +---------------------------------------------------------------- +instrFromOpcode :: Int -> Instr +instrFromOpcode i + | i >= length instrTable = error "Instr.instrFromOpcode: illegal opcode" + | otherwise = instrTable !! i + +opcodeFromInstr :: Instr -> Int +opcodeFromInstr instr + = walk 0 instrTable + where + walk _ [] = error "Instr.opcodeFromInstr: no opcode defined for this instruction" + walk opc (i:is) | instr == i = opc + | otherwise = (walk $! (opc+1)) is + +instrTable :: [Instr] +instrTable = + [ ARGCHK 0, PUSHCODE global, PUSHCONT 0, PUSHVAR var + , PUSHINT 0, PUSHFLOAT 0, PUSHBYTES mempty 0, SLIDE 0 0 0, STUB var + , ALLOCAP 0, PACKAP var 0, PACKNAP var 0, NEWAP 0, NEWNAP 0 + , ENTER, RETURN, PUSHCATCH, RAISE, CALL global + , ALLOCCON con, PACKCON con var, NEWCON con + --, UNPACKCON 0 , TESTCON id [], TESTINT 0 [] + , NOP, NOP, NOP + , ADDINT, SUBINT, MULINT, DIVINT, MODINT, QUOTINT, REMINT + , ANDINT, XORINT, ORINT, SHRINT, SHLINT, SHRNAT, NEGINT + , EQINT, NEINT, LTINT, GTINT, LEINT, GEINT + , ALLOC, NEW 0, GETFIELD, SETFIELD, GETTAG, GETSIZE, PACK 0 var, UNPACK 0 + , PUSHVAR0, PUSHVAR1, PUSHVAR2, PUSHVAR3, PUSHVAR4 + -- , PUSHVARS2 id 0 id 0, PUSHVARS3 id 0 id 0 id 0, PUSHVARS4 id 0 id 0 id 0 id 0 + , PUSHVARS2 var var, NOP, NOP + , NOP, NEWAP2, NEWAP3, NEWAP4 + , NOP, NEWNAP2, NEWNAP3, NEWNAP4 + , NEWCON0 con, NEWCON1 con, NEWCON2 con, NEWCON3 con + , ENTERCODE global, EVALVAR var, RETURNCON con, RETURNINT 0, RETURNCON0 con + , MATCHCON [], SWITCHCON [], MATCHINT [], NOP {- MATCHFLOAT -}, MATCH [] + , NOP {- ENTERFLOAT -}, ADDFLOAT, SUBFLOAT, MULFLOAT, DIVFLOAT, NEGFLOAT + , EQFLOAT, NEFLOAT, LTFLOAT, GTFLOAT, LEFLOAT, GEFLOAT + -- Additional experimental instructions (AD, 20040108) + , UPDFIELD + ] + where + dum = dummyId + var = Var dum 0 0 + global = Global dum 0 0 + con = Con dum 0 0 0 + + +---------------------------------------------------------------- +-- Instruction enumeration +---------------------------------------------------------------- + +isCATCH :: Instr -> Bool +isCATCH (CATCH _) = True +isCATCH _ = False + +enumFromInstr :: Instr -> Int +enumFromInstr instr + = case instr of + -- pseudo instructions + VAR {} -> -1 + PARAM {} -> -2 + USE {} -> -3 + NOP -> -4 + ATOM {} -> -5 + INIT {} -> -6 + + + -- structured instructions + CATCH {} -> 0 + EVAL {} -> 1 + RESULT {} -> 2 + + MATCHCON {} -> 3 + SWITCHCON {} -> 4 + MATCHINT {} -> 5 + MATCH {} -> 6 + + -- push instructions + PUSHVAR {} -> 10 + PUSHINT {} -> 11 + PUSHBYTES {} -> 12 + PUSHFLOAT {} -> 13 + PUSHCODE {} -> 14 + PUSHCONT {} -> 15 + PUSHCATCH -> 16 + + -- stack instructions + ARGCHK {} -> 20 + SLIDE {} -> 21 + STUB {} -> 22 + + -- control + ENTER -> 30 + RAISE -> 31 + CALL {} -> 32 + + ENTERCODE {} -> 33 + EVALVAR {} -> 34 + + RETURN -> 35 + RETURNCON {} -> 36 + RETURNINT {} -> 37 + + -- applications + ALLOCAP {} -> 40 + PACKAP {} -> 41 + PACKNAP {} -> 42 + NEWAP {} -> 43 + NEWNAP {} -> 44 + + -- constructors + ALLOCCON {} -> 47 + PACKCON {} -> 48 + NEWCON {} -> 49 + + ALLOC -> 50 + NEW {} -> 51 + PACK {} -> 52 + UNPACK {} -> 53 + GETFIELD -> 54 + SETFIELD -> 55 + GETTAG -> 56 + GETSIZE -> 57 + UPDFIELD -> 58 + + -- INT operations + ADDINT -> 60 + SUBINT -> 61 + MULINT -> 62 + DIVINT -> 63 + MODINT -> 64 + QUOTINT -> 65 + REMINT -> 66 + ANDINT -> 67 + XORINT -> 68 + ORINT -> 69 + SHRINT -> 70 + SHLINT -> 71 + SHRNAT -> 72 + NEGINT -> 73 + + -- relative INT ops + EQINT -> 80 + NEINT -> 81 + LTINT -> 82 + GTINT -> 83 + LEINT -> 84 + GEINT -> 85 + + -- optimized instructions + PUSHVAR0 -> 100 + PUSHVAR1 -> 101 + PUSHVAR2 -> 102 + PUSHVAR3 -> 103 + PUSHVAR4 -> 104 + PUSHVARS2 {} -> 105 + + -- optimizes AP + NEWAP2 -> 111 + NEWAP3 -> 112 + NEWAP4 -> 113 + + NEWNAP2 -> 114 + NEWNAP3 -> 115 + NEWNAP4 -> 116 + + -- optimized NEWCON + NEWCON0 {} -> 120 + NEWCON1 {} -> 121 + NEWCON2 {} -> 122 + NEWCON3 {} -> 123 + + RETURNCON0 {} -> 124 + + -- FLOAT operations + ADDFLOAT -> 160 + SUBFLOAT -> 161 + MULFLOAT -> 162 + DIVFLOAT -> 163 + NEGFLOAT -> 164 + + -- relative FLOAT ops + EQFLOAT -> 180 + NEFLOAT -> 181 + LTFLOAT -> 182 + GTFLOAT -> 183 + LEFLOAT -> 184 + GEFLOAT -> 185 + + +---------------------------------------------------------------- +-- Instruction names +---------------------------------------------------------------- + +nameFromInstr :: Instr -> String +nameFromInstr instr + = case instr of + -- pseudo instructions + VAR {} -> "VAR" + PARAM {} -> "PARAM" + USE {} -> "USE" + NOP -> "NOP" + ATOM {} -> "ATOM" + INIT {} -> "INIT" + + + -- structured instructions + CATCH {} -> "CATCH" + EVAL {} -> "EVAL" + RESULT {} -> "RESULT" + + MATCHCON {} -> "MATCHCON" + SWITCHCON {} -> "SWITCHCON" + MATCHINT {} -> "MATCHINT" + MATCH {} -> "MATCH" + + -- push instructions + PUSHVAR {} -> "PUSHVAR" + PUSHINT {} -> "PUSHINT" + PUSHBYTES {} -> "PUSHBYTES" + PUSHFLOAT {} -> "PUSHFLOAT" + PUSHCODE {} -> "PUSHCODE" + PUSHCONT {} -> "PUSHCONT" + PUSHCATCH -> "PUSHCATCH" + + -- stack instructions + ARGCHK {} -> "ARGCHK" + SLIDE {} -> "SLIDE" + STUB {} -> "STUB" + + -- control + ENTER -> "ENTER" + RAISE -> "RAISE" + CALL {} -> "CALL" + + ENTERCODE {} -> "ENTERCODE" + EVALVAR {} -> "EVALVAR" + + RETURN -> "RETURN" + RETURNCON {} -> "RETURNCON" + RETURNINT {} -> "RETURNINT" + + -- applications + ALLOCAP {} -> "ALLOCAP" + PACKAP {} -> "PACKAP" + PACKNAP {} -> "PACKNAP" + NEWAP {} -> "NEWAP" + NEWNAP {} -> "NEWNAP" + + -- constructors + ALLOCCON {} -> "ALLOCCON" + PACKCON {} -> "PACKCON" + NEWCON {} -> "NEWCON" + + ALLOC -> "ALLOC" + NEW {} -> "NEW" + PACK {} -> "PACK" + UNPACK {} -> "UNPACK" + GETFIELD -> "GETFIELD" + SETFIELD -> "SETFIELD" + GETTAG -> "GETTAG" + GETSIZE -> "GETSIZE" + UPDFIELD -> "UPDFIELD" + + -- INT operations + ADDINT -> "ADDINT" + SUBINT -> "SUBINT" + MULINT -> "MULINT" + DIVINT -> "DIVINT" + MODINT -> "MODINT" + QUOTINT -> "QUOTINT" + REMINT -> "REMINT" + ANDINT -> "ANDINT" + XORINT -> "XORINT" + ORINT -> "ORINT" + SHRINT -> "SHRINT" + SHLINT -> "SHLINT" + SHRNAT -> "SHRNAT" + NEGINT -> "NEGINT" + + -- relative INT ops + EQINT -> "EQINT" + NEINT -> "NEINT" + LTINT -> "LTINT" + GTINT -> "GTINT" + LEINT -> "LEINT" + GEINT -> "GEINT" + + -- optimized instructions + PUSHVAR0 -> "PUSHVAR0" + PUSHVAR1 -> "PUSHVAR1" + PUSHVAR2 -> "PUSHVAR2" + PUSHVAR3 -> "PUSHVAR3" + PUSHVAR4 -> "PUSHVAR4" + + PUSHVARS2 {} -> "PUSHVARS2" + + + -- optimizes AP + NEWAP2 -> "NEWAP2" + NEWAP3 -> "NEWAP3" + NEWAP4 -> "NEWAP4" + + NEWNAP2 -> "NEWNAP2" + NEWNAP3 -> "NEWNAP3" + NEWNAP4 -> "NEWNAP4" + + -- optimized NEWCON + NEWCON0 {} -> "NEWCON0" + NEWCON1 {} -> "NEWCON1" + NEWCON2 {} -> "NEWCON2" + NEWCON3 {} -> "NEWCON3" + + RETURNCON0 {} -> "RETURNCON0" + + -- FLOAT operations + ADDFLOAT -> "ADDFLOAT" + SUBFLOAT -> "SUBFLOAT" + MULFLOAT -> "MULFLOAT" + DIVFLOAT -> "DIVFLOAT" + NEGFLOAT -> "NEGFLOAT" + + -- relative FLOAT ops + EQFLOAT -> "EQFLOAT" + NEFLOAT -> "NEFLOAT" + LTFLOAT -> "LTFLOAT" + GTFLOAT -> "GTFLOAT" + LEFLOAT -> "LEFLOAT" + GEFLOAT -> "GEFLOAT" diff --git a/Lvm/Instr/Resolve.hs b/Lvm/Instr/Resolve.hs new file mode 100644 --- /dev/null +++ b/Lvm/Instr/Resolve.hs @@ -0,0 +1,301 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Resolve.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Instr.Resolve (instrResolve) where + +import Control.Exception (assert) +import Data.Maybe +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Instr.Data + +{--------------------------------------------------------------- + resolve monad +---------------------------------------------------------------} +newtype Resolve a = R ((Base,Env,Depth) -> (a,Depth)) + +type Env = IdMap Depth +type Base = Depth + +find :: Id -> IdMap a -> a +find x env + = fromMaybe (error msg) (lookupMap x env) + where + msg = "InstrResolve.find: unknown identifier " ++ show x + +instance Functor Resolve where + fmap f (R r) = R (\ctx -> case r ctx of (x,d) -> (f x,d)) + +instance Monad Resolve where + return x = R (\(_,_,d) -> (x,d)) + (R r) >>= f = R (\ctx@(base,env,_) -> + case r ctx of + (x,depth') -> case f x of + R fr -> fr (base,env,depth')) + +{--------------------------------------------------------------- + non-proper morphisms +---------------------------------------------------------------} +pop :: Depth -> Resolve () +pop n + = push (-n) + +push :: Depth -> Resolve () +push n + = R (\(_,_,d) -> ((),d+n)) + +-- base :: Resolve Base +-- base = R (\(bas,_,d) -> (bas,d)) + +depth :: Resolve Depth +depth + = R (\(_,_,d) -> (d,d)) + +bind :: Id -> Resolve a -> Resolve a +bind x (R r) + = R (\(bas,env,d) -> r (bas,extendMap x d env,d)) + +based :: Resolve a -> Resolve a +based (R r) + = R (\(_,env,d) -> r (d,env,d)) + +resolveVar :: Var -> Resolve Var +resolveVar (Var x _ _) + = R (\(_,env,d) -> let xd = find x env in (Var x (d - xd) xd,d)) + +alternative :: Depth -> Resolve a -> Resolve a +alternative d (R r) + = R (\(bas,env,_) -> let (x,d1) = r (bas,env,d) + in assert (d1==d+1) (x,d1)) + -- "InstrResolve.alternative: invalid elements on the stack " ++ show depth' ++ ", " ++ show depth) + +runResolve :: Resolve a -> a +runResolve (R r) + = let (x,d) = r (0,emptyMap,0) + in assert (d==0) x -- "InstrResolve.runResolve: still elements on the stack (" ++ show depth ++ ")" + +{--------------------------------------------------------------- + codeResolver +---------------------------------------------------------------} +instrResolve :: [Instr] -> [Instr] +instrResolve instrs + = runResolve (resolves instrs) + +resolves :: [Instr] -> Resolve [Instr] +resolves instrs + = case instrs of + (PARAM x : rest) -> do{ push 1; bind x (resolves rest) } + (VAR x : rest) -> bind x (resolves rest) + (instr : rest) -> do{ is <- resolve instr + ; iss <- resolves rest + ; return (is ++ iss) + } + [] -> return [] + +resolve :: Instr -> Resolve [Instr] +resolve (PUSHVAR v) + = do{ var <- resolveVar v + ; push 1 + ; return [PUSHVAR var] + } + +resolve (STUB v) + = do{ var <- resolveVar v + ; return [STUB var] + } + +resolve (PACKAP v n) + = do{ var <- resolveVar v + ; pop n + ; return [PACKAP var n] + } + +resolve (PACKNAP v n) + = do{ var <- resolveVar v + ; pop n + ; return [PACKNAP var n] + } + +resolve (PACKCON con v) + = do{ var <- resolveVar v + ; pop (arityFromCon con) + ; return [PACKCON con var] + } + +resolve (PACK arity v) + = do{ var <- resolveVar v + ; pop arity + ; return [PACK arity var] + } + +resolve (EVAL _ is) + = do{ push 3 + ; d <- depth + ; is' <- based (resolves is) + ; pop 3 + ; push 1 + ; return [EVAL d is'] + } + +resolve (CATCH is) + = do{ pop 1 + ; push 3 + ; is' <- resolves is + ; return (PUSHCATCH : is') + } +{- + + = do{ b <- base + ; pop 1 + ; push 3 + ; is' <- based (resolves is) + ; d <- depth + ; pop (d-b) + ; return (PUSHCATCH : is') + } +-} +{- +resolve (RESULT is) + = do{ b <- base + ; d <- depth + ; is' <- resolves is + ; d' <- depth + ; pop (d' - b) + ; if (d' <= d) + then return (is' ++ [SLIDE 1 (d'-b-1) (d'-1), ENTER]) + else return (is' ++ [SLIDE (d'-d) (d-b) d,ENTER]) + } +-} +resolve (ATOM is) + = resolveSlide 1 is + +resolve (INIT is) + = resolveSlide 0 is + +resolve (MATCH alts) + = resolveAlts MATCH alts + +resolve (MATCHCON alts) + = resolveAlts MATCHCON alts + +resolve (SWITCHCON alts) + = resolveAlts SWITCHCON alts + +resolve (MATCHINT alts) + = resolveAlts MATCHINT alts + +resolve instr + = do{ effect instr; return [instr] } + +resolveSlide :: Depth -> [Instr] -> Resolve [Instr] +resolveSlide n is + = do{ d0 <- depth + ; is' <- resolves is + ; d1 <- depth + ; let m = d1-d0-n + ; pop m + ; return (is' ++ [SLIDE n m d1]) + } + +resolveAlts :: ([Alt] -> a) -> [Alt] -> Resolve [a] +resolveAlts match alts + = do{ pop 1 + ; d <- depth + ; alts' <- mapM (alternative d . resolveAlt) alts + ; return [match alts'] + } + +{- +resolveAlt (Alt pat []) + = do{ b <- base + ; d <- depth + ; pop (d-b) + ; return (Alt pat []) + } +-} +resolveAlt :: Alt -> Resolve Alt +resolveAlt (Alt pat []) + = do{ push 1 + ; return (Alt pat []) + } + + +resolveAlt (Alt pat is) + = do{ is' <- resolves is + ; return (Alt pat is') + } + +effect :: Instr -> Resolve () +effect instr + = case instr of + ENTER -> pop 1 + RAISE -> pop 1 + + CALL global -> do{ pop (arityFromGlobal global); push 1 } + + ALLOCAP {} -> push 1 + NEWAP n -> do{ pop n; push 1 } + NEWNAP n -> do{ pop n; push 1 } + + ALLOCCON {} -> push 1 + NEWCON con -> do{ pop (arityFromCon con); push 1 } + + NEW arity -> do{ pop 1; pop arity; push 1 } + UNPACK arity -> do{ pop 1; push arity } + + ALLOC -> do{ pop 2; push 1 } + GETFIELD -> do{ pop 2; push 1 } + SETFIELD -> pop 3 + GETTAG -> do{ pop 1; push 1 } + GETSIZE -> do{ pop 1; push 1 } + UPDFIELD -> do{ pop 3; push 1 } + + RETURNCON con -> pop (arityFromCon con) -- it is the last instruction! + + PUSHCODE _ -> push 1 + PUSHINT _ -> push 1 + PUSHFLOAT _ -> push 1 + PUSHBYTES _ _ -> push 1 + + PUSHCONT _ -> push 3 + PUSHCATCH -> do{ pop 1; push 3 } + + ADDINT -> pop 1 + SUBINT -> pop 1 + MULINT -> pop 1 + DIVINT -> pop 1 + MODINT -> pop 1 + QUOTINT -> pop 1 + REMINT -> pop 1 + + ANDINT -> pop 1 + XORINT -> pop 1 + ORINT -> pop 1 + SHRINT -> pop 1 + SHLINT -> pop 1 + SHRNAT -> pop 1 + + EQINT -> pop 1 + NEINT -> pop 1 + LTINT -> pop 1 + GTINT -> pop 1 + LEINT -> pop 1 + GEINT -> pop 1 + + ADDFLOAT -> pop 1 + SUBFLOAT -> pop 1 + MULFLOAT -> pop 1 + DIVFLOAT -> pop 1 + + EQFLOAT -> pop 1 + NEFLOAT -> pop 1 + LTFLOAT -> pop 1 + GTFLOAT -> pop 1 + LEFLOAT -> pop 1 + GEFLOAT -> pop 1 + + _ -> return () diff --git a/Lvm/Instr/Rewrite.hs b/Lvm/Instr/Rewrite.hs new file mode 100644 --- /dev/null +++ b/Lvm/Instr/Rewrite.hs @@ -0,0 +1,217 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Rewrite.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Instr.Rewrite (instrRewrite) where + +import Lvm.Instr.Data + +{--------------------------------------------------------------- + debugging +---------------------------------------------------------------} + +{- +showInstr instr + = showInstrs [instr] + +showInstrs instrs + = show (instrPretty instrs) + + +traceInstrs instrs + = trace ("trace:\n" ++ showInstrs instrs ++ "\n\n") instrs + -} + +{--------------------------------------------------------------- + rewrite rules +---------------------------------------------------------------} +instrRewrite :: [Instr] -> [Instr] +instrRewrite instrs + = peephole (rewrites (dummies (rewrites (rewrites instrs)))) + +rewrites :: [Instr] -> [Instr] +rewrites instrs + = case instrs of + -- TODO: the following three rules optimize things like (id x = x) but + -- this can probably be better done on the code generation level + PUSHVAR (Var _ 0 _) : SLIDE 1 m d : is + | m >= 1 + -> rewrites (SLIDE 1 (m-1) (d-1) : is) + + PUSHVAR (Var _ 1 _) : PUSHVAR (Var _ 1 _) : SLIDE 2 m d : is + | m >= 2 + -> rewrites (SLIDE 2 (m-2) (d-2) : is) + + PUSHVAR (Var _ 2 _) : PUSHVAR (Var _ 2 _) : PUSHVAR (Var _ 2 _) : SLIDE 3 m d : is + | m >= 3 + -> rewrites (SLIDE 3 (m-3) (d-3) : is) + + -- applications + NEWAP i : SLIDE n m d: ENTER : is + -> SLIDE (n+i-1) m (d+i-1): ENTER : rewrites is + + NEWNAP i : SLIDE n m d: ENTER : is + -> SLIDE (n+i-1) m (d+i-1): ENTER : rewrites is + + CALL global : SLIDE 1 m d: ENTER : is + -> SLIDE arity m (d+arity-1): CALL global : ENTER : rewrites is + where + arity = arityFromGlobal global + + -- returns + NEWCON con : SLIDE 1 m d: ENTER : is + -> SLIDE n m (d+n-1): RETURNCON con : rewrites is + where n = arityFromCon con + + PUSHINT i : SLIDE 1 m d: ENTER : is + -> SLIDE 0 m (d-1): RETURNINT i : rewrites is + + instr : SLIDE 1 m d: ENTER : is + | strictResult instr + -> instr : SLIDE 1 m d: RETURN : is + + -- eval and pushcode + PUSHCODE f : is + -> rewritePushCode f (rewrites is) + + EVAL d is' : is + -> rewriteEval d (rewrites is') is + + -- merge slides + SLIDE n0 m0 d0 : SLIDE n1 m1 _ : is + | n1 <= n0 -> rewrites (SLIDE n1 (m0+m1-(n0-n1)) d0 : is) + + -- essential rewrites + MATCH alts : is + -> [rewriteMatch MATCH alts is] + + MATCHCON alts : is + -> [rewriteMatch MATCHCON alts is] + + SWITCHCON alts : is + -> [rewriteMatch SWITCHCON alts is] + + MATCHINT alts : is + -> [rewriteMatch MATCHINT alts is] + + -- default + instr:rest -> instr:rewrites rest + [] -> [] + + +rewriteMatch :: ([Alt] -> a) -> [Alt] -> [Instr] -> a +rewriteMatch match alts is = match (map (rewriteAlt is) alts) + +rewriteAlt :: [Instr] -> Alt -> Alt +rewriteAlt instrs (Alt pat is) + | null is = Alt pat [] + | otherwise = Alt pat (rewrites (is ++ instrs)) + +-- rewrite PUSHCODE +rewritePushCode :: Global -> [Instr] -> [Instr] +rewritePushCode f instrs + = case instrs of + NEWAP n : is + | arity >= n -> PUSHCODE f : NEWNAP n : is + PACKAP var n : is + | arity >= n -> PUSHCODE f : PACKNAP var n : is + SLIDE n m d: ENTER : is + | arity == (n-1) && arity /= 0 -> SLIDE (n-1) m (d-1): ENTERCODE f : is + _ + -> PUSHCODE f : instrs + where + arity = arityFromGlobal f + +-- rewrite EVAL +rewriteEval :: Depth -> [Instr] -> [Instr] -> [Instr] +rewriteEval d evalis is + = case evalis of + [PUSHVAR (Var x ofs d1),SLIDE 1 0 _,ENTER] + -> rewrites (EVALVAR (Var x (ofs-3) d1) : is) + [PUSHVAR (Var x ofs dv),ENTER] + -> rewrites (EVALVAR (Var x (ofs-3) dv) : is) + _ -> EVAL d evalis : rewrites is + +{--------------------------------------------------------------- + peephole optimization +---------------------------------------------------------------} + +peephole :: [Instr] -> [Instr] +peephole = simplify shorten + +dummies :: [Instr] -> [Instr] +dummies = simplify id + +simplify :: (Instr -> Instr) -> [Instr] -> [Instr] +simplify single = walk + where + walk instrs + = case instrs of + -- structured + EVAL d is' : is -> EVAL d (walk is') : walk is + MATCH alts : is -> MATCH (map walkAlt alts) : walk is + MATCHCON alts : is -> MATCHCON (map walkAlt alts) : walk is + SWITCHCON alts : is -> SWITCHCON (map walkAlt alts) : walk is + MATCHINT alts : is -> MATCHINT (map walkAlt alts) : walk is + + -- dummy + NEWAP 1 : is -> walk is + NEWNAP 1 : is -> walk is + + -- slide + SLIDE _ 0 _ : is -> walk is + SLIDE 1 _ _ : RETURN : is -> walk (RETURN : is) + SLIDE n _ _ : RETURNCON con : is + | arityFromCon con == n -> walk (RETURNCON con : is) + SLIDE 0 _ _ : RETURNINT i : is + -> walk (RETURNINT i : is) + + -- shorten sequences + PUSHVAR v : PUSHVAR w : is + -> PUSHVARS2 v w : walk is + + -- default + instr:is -> single instr : walk is + [] -> [] + + walkAlt (Alt pat is) + = Alt pat (walk is) + +shorten :: Instr -> Instr +shorten instr + = case instr of + PUSHVAR var -> case offsetFromVar var of + 0 -> PUSHVAR0 + 1 -> PUSHVAR1 + 2 -> PUSHVAR2 + 3 -> PUSHVAR3 + 4 -> PUSHVAR4 + _ -> instr + + NEWAP n -> case n of + 2 -> NEWAP2 + 3 -> NEWAP3 + 4 -> NEWAP4 + _ -> instr + + NEWNAP n -> case n of + 2 -> NEWNAP2 + 3 -> NEWNAP3 + 4 -> NEWNAP4 + _ -> instr + + NEWCON con -> case arityFromCon con of + 0 -> NEWCON0 con + 1 -> NEWCON1 con + 2 -> NEWCON2 con + 3 -> NEWCON3 con + _ -> instr + + RETURNCON con -> case arityFromCon con of + 0 -> RETURNCON0 con + _ -> instr + + _ -> instr diff --git a/Lvm/Path.hs b/Lvm/Path.hs new file mode 100644 --- /dev/null +++ b/Lvm/Path.hs @@ -0,0 +1,79 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Path.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Path + ( getLvmPath, searchPath + , searchPathMaybe, splitPath + ) where + +import qualified Control.Exception as CE (catch, IOException) +import Data.List +import System.Directory +import System.Environment +import System.Exit + +---------------------------------------------------------------- +-- file searching +---------------------------------------------------------------- + +searchPath :: [String] -> String -> String -> IO String +searchPath path ext name = do + ms <- searchPathMaybe path ext name + case ms of + Just s -> return s + Nothing -> do + putStrLn ("Error: could not find " ++ show nameext) + putStrLn (" with search path " ++ show path) + exitFailure + where + nameext + | ext `isSuffixOf` name = name + | otherwise = name ++ ext + +searchPathMaybe :: [String] -> String -> String -> IO (Maybe String) +searchPathMaybe path ext name + = walk (map makeFName path) -- was ("":path), but we don't want to look in the current directory by default + where + walk [] = return Nothing + walk (fname:xs) = do{ exist <- doesFileExist fname + ; if exist + then return (Just fname) + else walk xs + } + + makeFName dir + | null dir = nameext + | last dir == '/' || + last dir == '\\' = dir ++ nameext + | otherwise = dir ++ "/" ++ nameext + + nameext + | ext `isSuffixOf` name = name + | otherwise = name ++ ext + +getLvmPath :: IO [String] +getLvmPath + = do{ xs <- getEnv "LVMPATH" + ; return (splitPath xs) + } + `CE.catch` handler + where + handler :: CE.IOException -> IO [String] + handler _ = return [] + +splitPath :: String -> [String] +splitPath = walk [] "" + where + walk ps p xs + = case xs of + [] -> if null p + then reverse ps + else reverse (reverse p:ps) + (';':cs) -> walk (reverse p:ps) "" cs + (':':'\\':cs) -> walk ps ("\\:" ++ p) cs + (':':cs) -> walk (reverse p:ps) "" cs + (c:cs) -> walk ps (c:p) cs diff --git a/Lvm/Read.hs b/Lvm/Read.hs new file mode 100644 --- /dev/null +++ b/Lvm/Read.hs @@ -0,0 +1,422 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Read.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Read (lvmReadFile, lvmRead) where + +import Control.Monad +import Data.Array +import Lvm.Common.Byte hiding (readByteList) +import Lvm.Common.Id +import Lvm.Data +import Lvm.Instr.Data +import Prelude hiding (Read) +import qualified Lvm.Common.Byte as Byte + +{-------------------------------------------------------------- + Magic numbers +--------------------------------------------------------------} +lvmMajor, lvmMinor :: Int +lvmMajor = 15 +lvmMinor = 0 + +data Record v = RecDecl (Decl v) + + | RecName Id + | RecKind Id + | RecBytes !Bytes + | RecCode ![Int] + | RecModule Id !Int !Int [Custom] + | RecExternType !String + | RecAnon !DeclKind [Custom] + +{-------------------------------------------------------------- + read an LVM file +--------------------------------------------------------------} + +{- +test src + = do{ path <- getLvmPath + ; source <- searchPath path ".lvm" src + ; mod <- lvmReadFile source + ; putDoc (modulePretty instrPretty mod) + } -} + +lvmReadFile :: FilePath -> IO (Module v) +lvmReadFile fname + = do{ bs <- Byte.readByteList fname + ; ns <- newNameSupply + ; return (lvmRead ns fname bs) + } + +lvmRead :: NameSupply -> FilePath -> [Byte] -> Module v +lvmRead = runRead readModule + +readModule :: Read v (Module v,[Record v]) +readModule + = do{ tag <- readRaw + ; readGuard (tag == recHeader) "readHeader" "magic number is incorrect" + ; _len <- readint + ; total <- readint + ; lvmmajor <- readint + ; lvmminor <- readint + ; readGuard (lvmmajor == lvmMajor && lvmminor >= lvmMinor) "readHeader" ("incompatible lvm version " ++ show lvmmajor ++ "." ++ show lvmminor) + ; count <- readint + ; _bcount <- readint + ; ~(x,major,minor) <- readModuleIdx + ; recs <- readRecords total [] + ; readGuard (count == length recs) "readModule" "incorrect record count" + ; return (Module x major minor [d | RecDecl d <- filter isRecDecl recs],recs) + } + where + isRecDecl (RecDecl _) = True + isRecDecl _ = False + +readRecords :: Int -> [Record v] -> Read v [Record v] +readRecords total acc + = do{ x <- readRaw + ; len <- readint + ; if x == recFooter + then do{ total' <- readint + ; readGuard (total==total') "readRecords" "footer doesn't match with header" + ; return (reverse acc) + } + else if isInt x + then do{ let tag = decodeInt x + ; rec_ <- case tag of + 0 -> readName len + 1 -> readKind len + 2 -> readBytes len + 3 -> readCode len + 4 -> readValue len + 5 -> readCon len + 6 -> readImport len + 7 -> readModuleRec len + 8 -> readExtern len + 9 -> readExternType len + _ -> readError "readRecords" ("unknown standard record kind (" ++ show tag ++ ")") + ; readRecords total (rec_:acc) + } + else do{ let idx = decodeIdx x + ; rec_ <- readDeclCustom idx len + ; readRecords total (rec_:acc) + } + } + + +{-------------------------------------------------------------- + declarations +--------------------------------------------------------------} +readValue :: Int -> Read v (Record v) +readValue len + = do{ x <- readNameIdx "value" + ; acc <- readAccess + ; arity <- readint + ; _ <- readEnclosing + ; _ <- readIdx "code" + ; customs<- readCustoms (len - 20) + ; return (RecDecl (DeclAbstract x acc arity customs)) + } + +readCon :: Int -> Read v (Record a) +readCon len + = do{ x <- readNameIdx "constructor" + ; acc <- readAccess + ; arity <- readint + ; tag <- readint + ; customs <- readCustoms (len - 16) + ; return (RecDecl (DeclCon x acc arity tag customs)) + } + +readImport :: Int -> Read v (Record v1) +readImport len + = do{ x <- readNameIdx "import" + ; flags <- readint + ; ~(modid,major,minor) <- readModuleIdx + ; impid <- readNameIdx "imported" + ; kind <- readKindIdx + ; customs <- readCustoms (len - 20) + ; return (RecDecl (DeclImport x (Imported (odd flags) modid impid kind major minor) customs)) + } + +readKindIdx :: Read v DeclKind +readKindIdx + = do{ xkind <- readRaw + ; if isInt xkind + then return (toEnum (decodeInt xkind)) + else do{ kindid <- resolveKindIdx (decodeIdx xkind) + ; return (DeclKindCustom kindid) + } + } +readModuleRec :: Int -> Read v (Record a) +readModuleRec len + = do{ x <- readNameIdx "module" + ; major <- readint + ; minor <- readint + ; customs <- readCustoms (len - 12) + ; return (RecModule x major minor customs) + } + +readDeclCustom :: Index -> Int -> Read v (Record v) +readDeclCustom kindIdx len + = do{ kindid <- resolveKindIdx kindIdx + ; mbId <- readCustomNameIdx + ; case mbId of + Just x -> do{ acc <- readAccess + ; customs <- readCustoms (len-8) + ; return (RecDecl (DeclCustom x acc (DeclKindCustom kindid) customs)) + } + Nothing -> do{ customs <- readCustoms (len-4) + ; return (RecAnon (DeclKindCustom kindid) customs) + } + } + +readExtern :: Int -> Read v (Record v) +readExtern len + = do{ x <- readNameIdx "extern" + ; acc <- readAccess + ; arity <- readint + ; tp <- readExternTypeIdx + ; libname <- readNameStringIdx + ; xname <- readRaw + ; mode <- readint + ; link <- readint + ; call <- readint + ; customs <- readCustoms (len - 9*4) + ; name <- case mode of + 1 -> fmap Decorate (readNameString (decodeIdx xname)) + 2 -> return (Ordinal (decodeInt xname)) + _ -> fmap Plain (readNameString (decodeIdx xname)) + ; let linkMode = case link of + 1 -> LinkDynamic + 2 -> LinkRuntime + _ -> LinkStatic + callMode = case call of + 1 -> CallStd + 2 -> CallInstr + _ -> CallC + ; return (RecDecl (DeclExtern x acc arity tp linkMode callMode libname name customs)) + } + +{-------------------------------------------------------------- + constants +--------------------------------------------------------------} +readCode :: Int -> Read v (Record v) +readCode len + = do{ ints <- mapM (const readRaw) [1..div len 4] + ; return (RecCode ints) + } + +readName :: Int -> Read v (Record v) +readName len + = do{ bs <- readByteSeq len + ; return (RecName (idFromString (stringFromByteList bs))) + } + +readKind :: Int -> Read v (Record v) +readKind len + = do{ bs <- readByteSeq len + ; return (RecKind (idFromString (stringFromByteList bs))) + } + +readBytes :: Int -> Read v (Record v) +readBytes len + = do{ bs <- readByteSeq len + ; return (RecBytes (bytesFromByteList bs)) + } + +readExternType :: Int -> Read v (Record a) +readExternType len + = do{ bs <- readByteSeq len + ; return (RecExternType (stringFromByteList bs)) + } + +readByteSeq :: Int -> Read v [Byte] +readByteSeq len + = do{ blen <- readint + ; bs <- readByteList blen + ; skip (len - 4 - blen) + ; return bs + } + +readCustoms :: Int -> Read v [Custom] +readCustoms len + = mapM (const readCustom) [1..div len 4] + +readAccess :: Read v Access +readAccess + = do{ flags <- readint + ; return (Defined (odd flags)) + } + +readCustom :: Read v Custom +readCustom + = do{ x <- readRaw + ; if isInt x + then return (CustomInt (decodeInt x)) + else if decodeIdx x == 0 + then return CustomNothing + else resolve (decodeIdx x) recToCustom + } + where + recToCustom rec_ + = case rec_ of + RecName x -> CustomName x + RecBytes bs -> CustomBytes bs + RecDecl d -> CustomLink (declName d) (declKindFromDecl d) + RecAnon kind cs -> CustomDecl kind cs + _ -> error "LvmRead.readCustom: invalid link" + + +{-------------------------------------------------------------- + indices +--------------------------------------------------------------} +readNameIdx :: String -> Read v Id +readNameIdx parent + = do{ idx <- readIdx (parent ++ ".name") + ; if idx == 0 + then readFreshId + else resolve idx (\rec_ -> case rec_ of + RecName x -> x + _ -> error "LvmRead.readName: invalid name index") + } + +readCustomNameIdx :: Read v (Maybe Id) +readCustomNameIdx + = do{ idx <- readIdx "custom name" + ; if idx==0 + then return Nothing + else do{ x1 <- resolve idx (\rec_ -> case rec_ of + RecName x2 -> x2 + _ -> error "LvmRead.readCustomNameIdx: invalid name index") + ; return (Just x1) + } + } + +resolveKindIdx :: Index -> Read v Id +resolveKindIdx idx + = resolve idx (\rec_ -> case rec_ of + RecKind x -> x + _ -> error "LvmRead.resolveKindIdx: invalid kind index") + +readModuleIdx :: Read v (Id, Int, Int) +readModuleIdx + = do{ idx <- readIdx "module descriptor" + ; resolve idx (\rec_ -> case rec_ of + RecModule modid major minor _ -> (modid,major,minor) + _ -> error "LvmRead.readModule: invalid module index") + } + +readExternTypeIdx :: Read v String +readExternTypeIdx + = do{ idx <- readIdx "extern type" + ; resolve idx (\rec_ -> case rec_ of + RecExternType tp -> tp + _ -> error "LvmRead.readExternType: invalid extern type index") + } + +readNameStringIdx :: Read v String +readNameStringIdx + = do{ idx <- readIdx "name string" + ; readNameString idx + } + +readNameString :: Int -> Read v String +readNameString idx + = resolve idx (\rec_ -> case rec_ of + RecName x -> stringFromId x + RecBytes bs -> stringFromBytes bs + _ -> error "LvmRead.readNameString: invalid name index") + +readEnclosing :: Read a (Maybe Id) +readEnclosing + = do{ idx <- readIdx "enclosing" + ; if idx == 0 + then return Nothing + else resolve idx (\rec_ -> case rec_ of + RecDecl d | isDeclValue d || isDeclAbstract d -> Just (declName d) + _ -> error "readEnclosing" "invalid enclosing index" + ) + } + + + +readint :: Read v Int +readint + = do{ i <- readRaw + ; readGuard (isInt i) "readint" "expecting integer but found index" + ; return (decodeInt i) + } +readIdx :: String -> Read v Int +readIdx name + = do{ i <- readRaw + ; readGuard (isIdx i) "readIdx" ("expecting index but found integer (" ++ name ++ ")") + ; return (decodeIdx i) + } + +isInt, isIdx :: Int -> Bool +isInt = odd +isIdx = even + +decodeInt, decodeIdx :: Int -> Int +decodeInt i = (i-1) `div` 2 +decodeIdx i = i `div` 2 + +{-------------------------------------------------------------- + Reader monad. + Note the lazy recursive definition, where resolving + and reading is done in a single pass (using delayed + computations). +--------------------------------------------------------------} +newtype Read v a = Read (Env v -> State -> Result a) +type Records v = Array Int (Record v) +data Result a = Result a !State +data Env v = Env !FilePath (Records v) +data State = State ![Byte] !NameSupply + +unRead :: Read a b -> Env a -> State -> Result b +unRead (Read r) = r + +runRead :: Read v (a,[Record v]) -> NameSupply -> FilePath -> [Byte]-> a +runRead (Read r) ns fname bs + = let (Result (x,rs) _) = r (Env fname (listArray (1,length rs) rs)) (State bs ns) + in x + +instance Functor (Read v) where + fmap f (Read r) = Read (\env st1 -> case r env st1 of + Result x st2 -> Result (f x) st2) +instance Monad (Read v) where + return x = Read (\_ bs -> Result x bs) + (Read r) >>= f = Read (\rs bs -> case r rs bs of + Result x bsx -> unRead (f x) rs bsx) + + +readRaw :: Read v Int +readRaw + = Read (\_ (State bs ns) -> case int32FromByteList bs of (i,cs) -> Result i (State cs ns)) + +readByteList :: Int -> Read v [Byte] +readByteList n + = Read (\_ (State bs ns) -> case splitAt n bs of (xs,cs) -> Result xs (State cs ns)) + +skip :: Int -> Read v () +skip n + = Read (\_ (State bs ns) -> Result () (State (drop n bs) ns)) + +readFreshId :: Read v Id +readFreshId + = Read (\_ (State bs ns) -> let (x,ns') = freshId ns in Result x (State bs ns')) + +readGuard :: Bool -> String -> String -> Read v () +readGuard test fun = unless test . readError fun + +readError :: String -> String -> Read v a +readError fun msg + = Read (\(Env fname _) _ -> error ("LvmRead." ++ fun ++ ": \"" ++ fname ++ "\"\n " ++ msg)) + +resolve :: Int -> (Record v -> a) -> Read v a +resolve idx f + = Read (\(Env _ rs) st -> Result (f (rs ! idx)) st) diff --git a/Lvm/Write.hs b/Lvm/Write.hs new file mode 100644 --- /dev/null +++ b/Lvm/Write.hs @@ -0,0 +1,543 @@ +-------------------------------------------------------------------------------- +-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file +-- is distributed under the terms of the BSD3 License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +-------------------------------------------------------------------------------- +-- $Id: Write.hs 291 2012-11-08 11:27:33Z heere112 $ + +module Lvm.Write (lvmWriteFile, lvmToBytes) where + +import qualified Control.Exception as CE (assert, catch, IOException) +import Control.Monad +import Data.Maybe +import Lvm.Common.Byte +import Lvm.Common.Id +import Lvm.Common.IdMap +import Lvm.Data +import Lvm.Instr.Data +import System.Exit + +{-------------------------------------------------------------- + Magic numbers +--------------------------------------------------------------} +lvmMajorVersion,lvmMinorVersion :: Int +lvmMajorVersion = 15 +lvmMinorVersion = 0 + +{-------------------------------------------------------------- + Emit an LVM file +--------------------------------------------------------------} +lvmWriteFile :: FilePath -> LvmModule -> IO () +lvmWriteFile path lvm + = let bytes = lvmToBytes lvm + in seq bytes $ + writeBytes path bytes `CE.catch` (\exception -> + let message = show (exception :: CE.IOException) ++ "\n\nUnable to write to file " ++ show path + in do { putStrLn message; exitWith (ExitFailure 1) }) + +lvmToBytes :: LvmModule -> Bytes +lvmToBytes m + = let (idxInfo,recs) = bytesFromModule m + headerlen = 24 + header = block + [ recHeader + , encodeInt headerlen + , encodeInt totallen + , encodeInt lvmMajorVersion + , encodeInt lvmMinorVersion + , encodeInt (length recs) + , encodeInt (bytesLength brecs) + , encodeIdx idxInfo + ] + + footerlen = 4 + footer = block [ recFooter, encodeInt footerlen, encodeInt totallen ] + + brecs = mconcat recs + totallen = bytesLength brecs + headerlen + 8 + footerlen + 8 + total = mconcat [header,brecs,footer] + in seq totallen total + +bytesFromModule :: LvmModule -> (Index,[Bytes]) +bytesFromModule = runEmit . emitLvmModule + + +emitLvmModule :: LvmModule -> Emit Index +emitLvmModule m + = do{ idxInfo <- emitModule (moduleName m) (moduleMajorVer m) (moduleMinorVer m) + ; mapM_ emitDecl (moduleDecls m) + ; return idxInfo + } + +{-------------------------------------------------------------- + emit declarations + TODO: emit assumes some canonical order: We should do + allocation of named blocks first and than emit to fix this. +--------------------------------------------------------------} +flags :: Access -> Int +flags access = if accessPublic access then 1 else 0 + +isImported :: Decl v -> Bool +isImported decl + = case declAccess decl of + Imported{} -> True + _ -> False + +emitDecl :: Decl [Instr] -> Emit Index +emitDecl DeclExtern{ externCall = CallInstr } + = return 0 +emitDecl decl + | isImported decl = emitImport (declName decl) (declKindFromDecl decl) (declAccess decl) [] +emitDecl decl + = case decl of + DeclValue{} -> emitDValue decl + DeclAbstract{} -> emitDAbstract decl + DeclCon{} -> emitDCon decl + DeclExtern{} -> emitDExtern decl + DeclCustom{} -> emitDCustom decl + _ -> error "LvmWrite.emitDecl: invalid declaration at this phase" + +emitDValue :: Decl [Instr] -> Emit Index +emitDValue (DeclValue x access mbEnc instrs custom) + = do{ idxEnc <- maybe (return 0) (findIndex DeclKindValue) mbEnc + ; idxCode <- emitInstrs instrs + ; emitNamedBlock x DeclKindValue [encodeInt (flags access), encodeInt arity + ,encodeIdx idxEnc, encodeIdx idxCode] custom + } + where + arity = case instrs of + (ARGCHK n:_ ) -> n + _ -> error ("LvmWrite.emitDecl: instructions do not start with an argument check: " ++ show x) +emitDValue _ = error "Lvm.Write" + +emitDCon :: Decl a -> Emit Index +emitDCon (DeclCon x access arity tag custom) + = emitNamedBlock x DeclKindCon [encodeInt (flags access),encodeInt arity,encodeInt tag] custom +emitDCon _ = error "Lvm.Write" + +emitDCustom :: Decl a -> Emit Index +emitDCustom (DeclCustom x access kind custom) + = emitNamedBlock x kind [encodeInt (flags access)] custom +emitDCustom _ = error "Lvm.Write" + +emitDExtern :: Decl a -> Emit Index +emitDExtern (DeclExtern x access arity tp linkconv callconv libname externname custom) + = do{ idxType <- emitExternType tp + ; idxLibName <- emitNameString libname + ; (nameFlag,idxName) <- emitNameExtern + ; idxId <- emitName x + ; emitBlockEx (Just x) DeclKindValue DeclKindExtern + (block [encodeIdx idxId, encodeInt (flags access), encodeInt arity + ,encodeIdx idxType + ,encodeIdx idxLibName + ,idxName -- already encoded + ,encodeInt nameFlag + ,encodeInt (fromEnum linkconv) + ,encodeInt (fromEnum callconv) + ]) custom + } + where + emitNameExtern = case externname of + Plain s -> do{ idx <- emitNameString s; return (0,encodeIdx idx) } + Decorate s -> do{ idx <- emitNameString s; return (1,encodeIdx idx) } + Ordinal i -> return (2,encodeInt i) +emitDExtern _ = error "Lvm.Write" + +emitDAbstract :: Decl a -> b +emitDAbstract _ = error "LvmWrite.emitDAbstract: abstract values should be imported" + +emitImport :: Id -> DeclKind -> Access -> [Custom] -> Emit Index +emitImport x declkind access@(Imported _ modName impName kind majorVer minorVer) customs + = CE.assert (declkind==kind) $ -- LvmWrite.emitImport: kinds don't match + do{ idxModule <- emitModule modName majorVer minorVer + ; idxName <- emitName impName + ; idxId <- emitName x + ; kindenc <- encodeKind declkind + ; emitBlockEx (Just x) declkind DeclKindImport + (block [encodeIdx idxId, encodeInt (flags access), encodeIdx idxModule + , encodeIdx idxName, kindenc]) customs + } +emitImport _ _ _ _ = error "LvmWrite.emitImport: unknown case" + +emitModule :: Id -> Int -> Int -> Emit Index +emitModule name major minor + = do{ idxName <- emitName name + ; emitBlock Nothing DeclKindModule (block [encodeIdx idxName,encodeInt major,encodeInt minor]) [] + } + +{-------------------------------------------------------------- + emit instructions +--------------------------------------------------------------} +emitInstrs :: [Instr] -> Emit Index +emitInstrs instrs + = do{ rinstrs <- mapM resolve instrs + ; let codes = concatMap emit rinstrs + ; emitBlock Nothing DeclKindCode (block codes) [] + } +{- +emitCode :: (Id,LvmValue) -> Emit Index +emitCode (id,DValue access mbEnc instrs custom) + = do{ idx <- findIndex id + ; rinstrs <- mapM resolve instrs + ; let codes = concatMap emit rinstrs + ; emitBlock Nothing recCode (block (idx:codes)) [] + } + +emitCode other + = return 0 +-} + +{-------------------------------------------------------------- + emit an instruction +--------------------------------------------------------------} + +emits :: [Instr] -> [Int] +emits = concatMap emit + +emit :: Instr -> [Int] +emit instr + = let opcode = opcodeFromInstr instr + illegal = error ("LvmWrite.emit: illegal instruction at this phase: " ++ show (nameFromInstr instr)) + todo = error ("LvmWrite.emit: todo: " ++ show (nameFromInstr instr)) + in case instr of + -- pseudo instructions + VAR _ -> [] + PARAM _ -> [] + USE _ -> [] + NOP -> illegal + RESULT _ -> illegal + + -- structured instructions + MATCH alts -> opcode : emitMatch 3 alts + MATCHCON alts -> opcode : emitMatch 2 alts + MATCHINT alts -> opcode : emitMatch 2 alts + SWITCHCON _ -> todo + + EVAL _ is -> let scrut = emits is + in emit (PUSHCONT (length scrut)) ++ scrut + + -- push instructions + PUSHVAR var -> [opcode, offsetFromVar var] + PUSHINT n -> [opcode, n] + PUSHBYTES _ c -> [opcode, c] + PUSHFLOAT _ -> todo + PUSHCODE global -> [opcode, indexFromGlobal global] + PUSHCONT ofs -> [opcode, ofs] + + -- stack instructions + ARGCHK n -> [opcode, n] + SLIDE n m _ -> [opcode, n, m] + STUB var -> [opcode, offsetFromVar var] + + -- control + ENTER -> [opcode] + PUSHCATCH -> [opcode] + RAISE -> [opcode] + CALL global -> [opcode, indexFromGlobal global, arityFromGlobal global] + + ENTERCODE global -> [opcode, indexFromGlobal global] + EVALVAR var -> [opcode, offsetFromVar var] + + RETURN -> [opcode] + RETURNCON con -> [opcode, indexFromCon con, arityFromCon con] + RETURNINT i -> [opcode, i] + + -- applications + ALLOCAP arity -> [opcode, arity] + PACKAP var arity -> [opcode, offsetFromVar var, arity] + PACKNAP var arity -> [opcode, offsetFromVar var, arity] + NEWAP arity -> [opcode, arity] + NEWNAP arity -> [opcode, arity] + + -- constructors + ALLOCCON con -> [opcode, indexFromCon con, arityFromCon con] + PACKCON con var -> [opcode, offsetFromVar var, arityFromCon con] --TODO: constant instead of arity + + NEWCON con -> [opcode, indexFromCon con, arityFromCon con] + + NEW arity -> [opcode, arity] + PACK arity v -> [opcode, arity, offsetFromVar v] + UNPACK arity -> [opcode, arity] + + -- optimized instructions + PUSHVARS2 v w -> [opcode, offsetFromVar v, offsetFromVar w] + + NEWCON0 con -> [opcode, indexFromCon con] + NEWCON1 con -> [opcode, indexFromCon con] + NEWCON2 con -> [opcode, indexFromCon con] + NEWCON3 con -> [opcode, indexFromCon con] + + RETURNCON0 con -> [opcode, indexFromCon con] + + -- single opcode instructions + _ -> [opcode] + +emitMatch :: Int -> [Alt] -> [Int] +emitMatch entrySize alts + = CE.assert (normalizedAlts alts) $ -- "LvmWrite.emitMatch: unnormalized alternatives" + let (pats,iss) = unzipAlts alts + altis = map emits iss + start = 2 + entrySize*(length alts -1) + in [length alts-1] + ++ matches start (zip pats (map length altis)) + ++ concat altis + where + matches _ [] = [] + matches top ((pat,n):xs) + = (case pat of + PatCon con -> [indexFromCon con] + PatInt i -> [i] + PatTag t a -> [t,a] + PatDefault -> []) + ++ [if n==0 then 0 else top] ++ matches (top+n) xs + + +normalizedAlts :: [Alt] -> Bool +normalizedAlts alts + = case alts of + Alt PatDefault _:_ -> True + _ -> False + +unzipAlts :: [Alt] -> ([Pat], [[Instr]]) +unzipAlts alts + = unzip (map (\(Alt pat expr) -> (pat,expr)) alts) + + +{-------------------------------------------------------------- + resolve instructions +--------------------------------------------------------------} + +resolves :: ([Instr] -> a) -> [Instr] -> Emit a +resolves f is + = do{ ris <- mapM resolve is + ; return (f ris) + } + +resolve :: Instr -> Emit Instr +resolve instr + = case instr of + EVAL d is -> resolves (EVAL d) is + RESULT is -> resolves RESULT is + MATCH alts -> resolveAlts MATCH alts + MATCHCON alts -> resolveAlts MATCHCON alts + MATCHINT alts -> resolveAlts MATCHINT alts + SWITCHCON alts -> resolveAlts SWITCHCON alts + + PUSHCODE global -> resolveGlobal PUSHCODE global + ENTERCODE global-> resolveGlobal ENTERCODE global + CALL global -> resolveGlobal CALL global + + RETURNCON con -> resolveCon RETURNCON con + ALLOCCON con -> resolveCon ALLOCCON con + NEWCON con -> resolveCon NEWCON con + PACKCON con var -> resolveCon (`PACKCON` var) con + + PUSHBYTES bs _ -> resolveBytes (PUSHBYTES bs) bs + + -- optimized instructions + RETURNCON0 con -> resolveCon RETURNCON0 con + NEWCON0 con -> resolveCon NEWCON0 con + NEWCON1 con -> resolveCon NEWCON1 con + NEWCON2 con -> resolveCon NEWCON2 con + NEWCON3 con -> resolveCon NEWCON3 con + + _ -> return instr + +resolveAlts :: ([Alt] -> a) -> [Alt] -> Emit a +resolveAlts f = liftM f . mapM resolveAlt + +resolveAlt :: Alt -> Emit Alt +resolveAlt (Alt pat is) + = do{ pat' <- resolvePat pat + ; resolves (Alt pat') is + } + +resolvePat :: Pat -> Emit Pat +resolvePat pat + = case pat of + PatCon con -> resolveCon PatCon con + _ -> return pat + +resolveGlobal :: (Global -> a) -> Global -> Emit a +resolveGlobal f (Global x _ arity) + = do{ idx <- findIndex DeclKindValue x + ; return (f (Global x idx arity)) + } + +resolveCon :: (Con -> a) -> Con -> Emit a +resolveCon f (Con x _ arity tag) + = do{ idx <- findIndex DeclKindCon x + ; return (f (Con x idx arity tag)) + } + +resolveBytes :: (Index -> a) -> Bytes -> Emit a +resolveBytes f bs + = do{ idx <- emitBytes bs + ; return (f idx) + } + +{-------------------------------------------------------------- + basic entities +--------------------------------------------------------------} +emitNamedBlock :: Id -> DeclKind -> [Int] -> [Custom] -> Emit Index +emitNamedBlock x kind is custom + = do{ idxName <- emitName x + ; emitBlock (Just x) kind (block (encodeIdx idxName:is)) custom + } + +emitName :: Id -> Emit Index +emitName x + = emitNameString (stringFromId x) + +emitNameString :: String -> Emit Index +emitNameString s + = emitBlock Nothing DeclKindName (blockString s) [] + +emitExternType :: String -> Emit Index +emitExternType tp + = emitBlock Nothing DeclKindExternType (blockString tp) [] + +emitKind :: Id -> Emit Index +emitKind x + = emitBlock Nothing DeclKindKind (blockString (stringFromId x)) [] + +emitBytes :: Bytes -> Emit Index +emitBytes bs + = emitBlock Nothing DeclKindBytes (blockBytes bs) [] + +emitBlock :: Maybe Id -> DeclKind -> Bytes -> [Custom] -> Emit Index +emitBlock mbId kind = emitBlockEx mbId kind kind + +emitBlockEx :: Maybe Id -> DeclKind -> DeclKind -> Bytes -> [Custom] -> Emit Index +emitBlockEx mbId kindId kind bs custom + = do{ bcustom <- emitCustoms custom + ; kindenc <- encodeKind kind + ; let bytes = mappend bs bcustom + total = mappend (block [kindenc,encodeInt (bytesLength bytes)]) bytes + ; CE.assert ((bytesLength bytes `mod` 4) == 0) $ -- "LvmWrite.emitBlock: unaligned size" + emitPrimBlock (maybe Nothing (\x -> Just (x,kindId)) mbId) kind total + } + +encodeKind :: DeclKind -> Emit Int +encodeKind (DeclKindCustom x) + = do{ idx <- emitKind x + ; return (encodeIdx idx) + } + +encodeKind kind + = return (encodeInt (fromEnum kind)) + + +{-------------------------------------------------------------- + custom fields +--------------------------------------------------------------} +emitCustoms :: [Custom] -> Emit Bytes +emitCustoms decls + = do{ is <- mapM emitCustom decls + ; return (block is) + } + +emitCustom :: Custom -> Emit Int +emitCustom custom + = case custom of + CustomInt i -> return (encodeInt i) + CustomNothing -> return (encodeIdx 0) + CustomBytes bs -> do{ idx <- emitBytes bs; return (encodeIdx idx) } + CustomName x -> do{ idx <- emitName x; return (encodeIdx idx) } + CustomLink x kind -> do{ idx <- findIndex kind x; return (encodeIdx idx) } + CustomDecl kind cs -> do{ idx <- emitAnonymousCustom kind cs; return (encodeIdx idx) } + +emitAnonymousCustom :: DeclKind -> [Custom] -> Emit Index +emitAnonymousCustom kind + = emitBlock Nothing kind (block [encodeIdx 0]) + + +{-------------------------------------------------------------- + Emit Monad +--------------------------------------------------------------} +newtype Emit a = Emit (Env -> State -> (a,State)) +data State = State !Int Env [Bytes] +type Env = IdMap [(DeclKind,Index)] + +instance Functor Emit where + fmap f (Emit e) = Emit (\env st -> case e env st of + (x,stx) -> (f x,stx)) + +instance Monad Emit where + return x = Emit (\_ st -> (x,st)) + (Emit e) >>= f = Emit (\env st -> case e env st of + (x,stx) -> case f x of + Emit ef -> ef env stx) + +runEmit :: Emit a -> (a,[Bytes]) +runEmit (Emit e) + = let (x,State _ env bbs) = e env (State 0 emptyMap []) -- yes, a recursive, lazy, env :-) + in (x,reverse bbs) + +emitPrimBlock :: Maybe (Id,DeclKind) -> DeclKind -> Bytes -> Emit Index +emitPrimBlock mpair kind bs + = Emit (\_ (State count m1 bbs) -> + let (index,count2,bbs2) | sharable kind = case find count bs bbs of --try to share records + Nothing -> (count+1,count+1,bs:bbs) + Just idx -> (idx,count,bbs) + | otherwise = (count+1,count+1,bs:bbs) + m2 = case mpair of + Just (x,kindid) -> insertMapWith x [(kindid,index)] ((kindid,index):) m1 + Nothing -> m1 + in (index, State count2 m2 bbs2) + ) + +sharable :: DeclKind -> Bool +sharable _ = False +{- + = case kind of + DeclKindBytes -> True + DeclKindName -> True + DeclKindKind -> True + DeclKindExternType -> True + DeclKindModule -> True -- dubious when custom values are present! + other -> False +-} + +find :: Eq a => Int -> a -> [a] -> Maybe Int +find n _ [] = CE.assert (n==0) Nothing -- "LvmWrite.find: count too large" +find n x (y:ys) | x==y = Just n + | otherwise = (find $! (n-1)) x ys + +-- a nice lazy formulation, we can calculate all indices before writing the bytes. +findIndex :: DeclKind -> Id -> Emit Index +findIndex kind x + = Emit (\env st -> + (case lookupMap x env of + Nothing -> error ("LvmWrite.findIndex: undeclared identifier: " ++ show (stringFromId x)) + Just xs -> fromMaybe (error msg) (lookup kind xs) + , st)) + where + msg = "LvmWrite.findIndex: undeclared identifier (with the right declaration kind): " ++ show (stringFromId x) + + + +{-------------------------------------------------------------- + block +--------------------------------------------------------------} +block :: [Int] -> Bytes +block is + = mconcat (map bytesFromInt32 is) + +blockString :: String -> Bytes +blockString s + = blockBytes (bytesFromString s) + +blockBytes :: Bytes -> Bytes +blockBytes bs + = let len = bytesLength bs + in mconcat [bytesFromInt32 (encodeInt len), bs, padding len] + +padding :: Int -> Bytes +padding n + = let m = div (n + 3) 4 * 4 + in bytesFromList (replicate (m - n) (byteFromInt8 0)) + +encodeInt, encodeIdx :: Int -> Int +encodeInt i = (2*i)+1 +encodeIdx i = 2*i diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/lvmlib.cabal b/lvmlib.cabal new file mode 100644 --- /dev/null +++ b/lvmlib.cabal @@ -0,0 +1,82 @@ +name: lvmlib +version: 1.0 +synopsis: The Lazy Virtual Machine (LVM). +homepage: http://www.cs.uu.nl/wiki/bin/view/Helium/WebHome +description: + + The Lazy Virtual Machine (LVM) defines a portable instruction set and file + format. It is specifically designed to execute languages with non-strict (or + lazy) semantics. This cabal package defines the core assembler (coreasm) for + compiling core programs into LVM instructions and a library. The LVM is used + as a backend for the Helium compiler. At the moment, one LVM runtime + implementation is available (written in C). More information about LVM can be + found in Chapter 6 of Daan Leijen's PhD Thesis, The Lambda Abroad. + +category: Compilers/Interpreters +copyright: (c) 2012 +license: BSD3 +license-file: LICENSE.txt +author: Daan Leijen, Bastiaan Heeren, Jurriaan Hage +maintainer: helium@cs.uu.nl +stability: provisional +extra-source-files: CREDITS.txt +build-type: Simple +cabal-version: >= 1.10.1.0 +tested-with: GHC == 7.0.2, GHC == 7.0.3, GHC == 7.4.1 + +source-repository head + type: svn + location: https://svn.science.uu.nl/repos/sci.hage0101.lvm/trunk/src/lib + +-------------------------------------------------------------------------------- + +Executable coreasm + Build-Depends: base >= 3 && < 5, array, containers, directory, parsec, wl-pprint + ghc-options: -Wall + default-language: Haskell98 + hs-source-dirs: . + Main-is: Lvm/Core/Main.hs + +Library + Build-Depends: base >= 3 && < 5, array, containers, directory, parsec, wl-pprint + ghc-options: -Wall + default-language: Haskell98 + hs-source-dirs: . + Exposed-modules: + Lvm.Asm.Data + Lvm.Asm.Inline + Lvm.Asm.Occur + Lvm.Asm.ToLvm + Lvm.Common.Byte + Lvm.Common.Id + Lvm.Common.IdMap + Lvm.Common.IdSet + Lvm.Core.Expr + Lvm.Core.FreeVar + Lvm.Core.LetSort + Lvm.Core.Lift + Lvm.Core.Module + Lvm.Core.NoShadow + Lvm.Core.Normalize + Lvm.Core.Parsing.Layout + Lvm.Core.Parsing.Lexer + Lvm.Core.Parsing.Parser + Lvm.Core.Parsing.Token + Lvm.Core.PrettyId + Lvm.Core.RemoveDead + Lvm.Core.Saturate + Lvm.Core.ToAsm + Lvm.Core.Type + Lvm.Core.Utils + Lvm.Data + Lvm.Import + Lvm.Instr.Data + Lvm.Instr.Resolve + Lvm.Instr.Rewrite + Lvm.Path + Lvm.Read + Lvm.Write + + +-------------------------------------------------------------------------------- +