root/src/Pugs/Compile.hs

Revision 22313, 17.8 kB (checked in by pmurias, 3 weeks ago)

[pugs][smop]
lexical variable work in pugs -Cm0ld
Pugs.Compile.compile marks lexical delarations in PIL1 although not fully correctly
  • Property svn:mime-type set to text/plain; charset=UTF-8
  • Property svn:eol-style set to native
Line 
1{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp -fno-warn-deprecations -fallow-overlapping-instances #-}
2
3{-|
4    Compiler interface.
5
6>   And words unheard were spoken then
7>   Of folk and Men and Elven-kin,
8>   Beyond the world were visions showed
9>   Forbid to those that dwell therein...
10-}
11
12module Pugs.Compile (
13    PIL_Stmts(..), PIL_Stmt(..), PIL_Expr(..), PIL_Decl(..), PIL_Literal(..), PIL_LValue(..),
14    Compile(..),
15    TEnv(..), initTEnv,
16    TCxt(..), tcVoid, tcLValue,
17    TParam(..),
18    EnterClass(..),
19    die, varText
20) where
21import Pugs.AST
22import Pugs.Internals
23import Pugs.Types
24import Pugs.Monads
25import Pugs.PIL1
26import Language.PIR
27import Text.PrettyPrint
28import qualified Data.ByteString.Char8 as BS
29
30tcVoid, tcLValue :: TCxt
31tcVoid      = TCxtVoid
32tcLValue    = TCxtLValue anyType
33
34{-
35tcItem, tcSlurpy :: TCxt
36tcItem      = TCxtItem anyType
37tcSlurpy    = TCxtSlurpy anyType
38-}
39
40type Comp = Eval
41
42{-| Currently only 'Exp' → 'PIL' -}
43class (Show a, Typeable b) => Compile a b where
44    compile :: a -> Comp b
45    compile x = fail ("Unrecognized construct: " ++ show x)
46
47-- Compile instances
48instance Compile () PIL_Environment where
49    compile _ = do
50        glob    <- askGlobal
51        main    <- asks envBody
52        globPIL <- compile glob
53        mainPIL <- compile main
54        return $ PIL_Environment globPIL mainPIL
55
56instance Compile (Var, [(TVar Bool, TVar VRef)]) PIL_Decl where
57    compile = compError
58
59instance Compile Param TParam where
60    compile prm = do
61        defC <- if isOptional prm
62            then fmap Just $ compile (paramDefault prm)
63            else return Nothing
64        return $ MkTParam
65            { tpParam = prm
66            , tpDefault = defC
67            }
68
69{-| Compiles a 'Pad' to a list of 'PIL_Decl's. Currently, only subroutines and
70    @\@*END@ are compiled. -}
71instance Compile Pad [PIL_Decl] where
72    compile pad = do
73        entries' <- mapM canCompile entries
74        return $ concat entries'
75        where
76        entries = sortBy padSort [ (cast var, readPadEntry ref) | (var, ref) <- padToList pad ]
77        canCompile (name@('&':_) :: String, sym) = do
78            (ref :: VRef) <- sym
79            case ref of
80                MkRef ICode{} -> do
81                    codes <- readCodesFromRef ref
82                    fmap concat $ forM codes (doCode name)
83                MkRef (IScalar sv) | scalar_iType sv == mkType "Scalar::Const"
84                    -> doCode name =<< fromVal =<< scalar_fetch sv
85                _ -> return []
86        canCompile ("@*END", sym) = do
87            ref     <- sym
88            cvList  <- fromVals =<< readRef ref :: Comp [VCode]
89            decls   <- eachM cvList $ \(i, cv) -> do
90                compile (("&*END_" ++ show i), cv) :: Comp [PIL_Decl]
91            compile ("&*END", concat decls)
92        canCompile ((_:twigil:_), _) | not (isAlphaNum twigil) = return []
93        canCompile (name, sym) = do
94            -- translate them into store_global calls?
95            -- placing them each into one separate init function?
96            val     <- readRef =<< sym
97            valC    <- compile val
98            let assignC = PAssign [PVar name'] valC
99                bodyC   = PStmts (PStmt . PExp $ assignC) PNil
100                initL   = "__init_" ++ (render $ varText name)
101                name' | ':' `elem` name = name
102                      | otherwise = "Main::" ++ name -- XXX wrong
103            return [PSub initL SubPrim [] False False bodyC]
104        doCode name vsub = case subBody vsub of
105            Prim _  -> return []
106            _       -> compile (name, vsub)
107
108eachM :: (Monad m) => [a] -> ((Int, a) -> m b) -> m [b]
109eachM = forM . ([0..] `zip`)
110
111instance Compile (SubName, [PIL_Decl]) [PIL_Decl] where
112    compile (name, decls) = do
113        let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing []
114                    | PSub sub _ _ _ _ _ <- decls
115                    ]
116        return (PSub name SubPrim [] False False (combine bodyC PNil):decls)
117
118instance Compile (SubName, VCode) [PIL_Decl] where
119{-
120    compile (name, vsub) | packageOf name /= packageOf (subName vsub) = do
121        let storeC  = PBind [PVar $ qualify name] (PExp . PVar . qualify $ subName vsub)
122            bodyC   = PStmts (PStmt . PExp $ storeC) PNil
123            exportL = "__export_" ++ (render $ varText name)
124        return [PSub exportL SubPrim [] False False bodyC]
125-}
126    compile (name, vsub) = do
127        bodyC   <- enter cxtItemAny . compile $ case subBody vsub of
128            Syn "block" [body]  -> body
129            body                -> body
130        paramsC <- compile $ subParams vsub
131        return [PSub name (subType vsub) paramsC (subLValue vsub) (isMulti vsub) bodyC]
132
133instance Compile (String, PadEntry) PIL_Expr where
134    compile (name, entry) = do
135        rv <- readRef =<< readPadEntry entry
136        case rv of
137            VCode sub   -> return $ PRawName (cast $ subName sub)
138            _           -> return $ PRawName name
139
140instance Compile Exp PIL_Stmts where
141    -- XXX: pragmas?
142    compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest
143    compile (Ann Prag{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest
144    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest
145    compile (Ann _ rest) = compile rest
146{-
147    compile (Stmts (Pad SOur _ exp) rest) = do
148        compile $ mergeStmts exp rest
149    compile (Stmts (Pad scope pad exp) rest) = do
150        padC    <- compile [ (cast var :: String, ref) | (var, ref) <- padToList pad ]
151        let symC = (map (cast . fst) $ padToList pad) `zip` padC
152            exps = [ Syn ":=" [_Var name, _Var from]
153                   | (name, PRawName from) <- symC
154                   , name /= from
155                   ]
156        expC    <- compile $ mergeStmts (foldl1 mergeStmts (exps ++ [exp])) rest
157        return $ PPad scope symC expC
158-}
159    compile exp = compileStmts exp
160
161class EnterClass m a where
162    enter :: a -> m b -> m b
163
164instance EnterClass Comp VCode where
165    enter sub = local (\e -> e{ envLValue = subLValue sub, envContext = CxtItem (subReturns sub) })
166
167instance EnterClass Comp Cxt where
168    enter cxt = local (\e -> e{ envContext = cxt })
169
170compileStmts :: Exp -> Comp PIL_Stmts
171compileStmts exp = case exp of
172    Stmts this Noop -> do
173        thisC   <- compile this
174        return $ PStmts (tailCall thisC) PNil
175        where
176        tailCall (PStmt (PExp (PApp cxt fun inv args)))
177            = PStmt $ PExp $ PApp (TTailCall cxt) fun inv args
178        tailCall (PPos pos exp x) = PPos pos exp (tailCall x)
179        tailCall x = x
180    Stmts this (Syn "namespace" [Val (VStr sym), Val (VStr pkg), rest]) -> do
181        thisC   <- enter cxtVoid $ compile this
182        declC   <- enter cxtVoid $ compile decl
183        restC   <- enterPackage (cast pkg) $ compileStmts rest
184        return $ PStmts thisC $ PStmts declC restC
185        where
186          -- XXX - kludge.
187          decl = App (_Var func) Nothing [(Val (VStr pkg))]
188          func = "&" ++ (capitalize sym) ++ "::_create"
189          capitalize []     = []
190          capitalize (c:cs) = toUpper c:cs
191
192    Stmts this rest -> do
193        thisC   <- enter cxtVoid $ compile this
194        restC   <- compileStmts rest
195        return $ PStmts thisC restC
196    Noop        -> return PNil
197    _           -> compile (Stmts exp Noop)
198
199instance Compile Val PIL_Stmt where
200    compile = fmap PStmt . compile . Val
201
202instance Compile Val PIL_Expr where
203    compile = compile . Val
204
205instance Compile Exp PIL_Stmt where
206    compile (Ann (Pos pos) rest) = fmap (PPos pos rest) $ compile rest
207    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest
208    -- XXX: pragmas?
209    compile (Ann Prag{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest
210    compile (Ann _ rest) = compile rest
211    compile Noop = return PNoop
212    {-
213    compile (Val val) = do
214        cxt     <- asks envContext
215        if isVoidCxt cxt
216            then case val of
217                VBool True      -> compile Noop
218                _               -> do
219                    warn "Useless use of a constant in void context" val
220                    compile Noop
221            else compile val
222    -}
223    compile (Val val) = compile val
224    compile (Syn "loop" [exp]) =
225        compile (Syn "loop" $ [emptyExp, Val (VBool True), emptyExp, exp])
226    compile (Syn "loop" [pre, cond, post, body]) = do
227        preC    <- compile pre
228        -- loop (...; ; ...) {...} ->
229        -- loop (...; True; ...) {...}
230        let cond' | unwrap cond == Noop
231                  = return $ PStmts (PStmt . PLit . PVal $ VBool True) PNil
232                  | otherwise
233                  = compile cond
234        condC   <- cond'
235        bodyC   <- compile body
236        postC   <- compile post
237        funC    <- compile (_Var "&statement_control:loop")
238        return . PStmt . PExp $ PApp TCxtVoid funC Nothing
239            [preC, pBlock condC, bodyC, pBlock postC]
240    compile exp@(Syn "unless" _) = fmap (PStmt . PExp) $ compConditional exp
241    compile exp@(Syn "while" _) = compLoop exp
242    compile exp@(Syn "until" _) = compLoop exp
243    compile exp@(Syn "postwhile" _) = compLoop exp
244    compile exp@(Syn "postuntil" _) = compLoop exp
245    compile (Syn "for" [exp, body]) = do
246        expC    <- compile exp
247        bodyC   <- compile body
248        funC    <- compile (_Var "&statement_control:for")
249        return . PStmt . PExp $ PApp TCxtVoid funC Nothing [expC, bodyC]
250    compile (Syn "given" _) = compile (_Var "$_") -- XXX
251    compile (Syn "when" _) = compile (_Var "$_") -- XXX
252    compile exp = fmap PStmt $ compile exp
253
254pBlock :: PIL_Stmts -> PIL_Expr
255pBlock = PCode SubBlock [] False False
256
257{-
258subTCxt :: VCode -> Eval TCxt
259subTCxt sub = return $ if subLValue sub
260    then TCxtLValue (subReturns sub)
261    else TCxtItem (subReturns sub)
262-}
263
264askTCxt :: Eval TCxt
265askTCxt = do
266    env <- ask
267    return $ if envLValue env
268        then TCxtLValue (typeOfCxt $ envContext env)
269        else case envContext env of
270            CxtVoid         -> TCxtVoid
271            CxtItem typ     -> TCxtItem typ
272            CxtSlurpy typ   -> TCxtSlurpy typ
273
274instance (Compile a b) => Compile [a] [b] where
275    compile = fmapM compile
276
277instance (Compile a b, Compile a c) => Compile [a] (b, c) where
278    compile [x, y] = do { x' <- compile x ; y' <- compile y; return (x', y') }
279    compile x = compError x
280
281instance (Compile a b, Compile a c, Compile a d) => Compile [a] (b, c, d) where
282    compile [x, y, z] = do { x' <- compile x ; y' <- compile y; z' <- compile z; return (x', y', z') }
283    compile x = compError x
284
285instance Compile Exp PIL_LValue where
286    compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest
287    compile (Ann Prag{} rest) = compile rest
288    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest
289    compile (Ann _ rest) = compile rest
290    -- XXX: pragmas?
291    compile (Var name) = return $ _PVar name
292    compile (Syn (sigil:"::()") exps) = do
293        compile $ App (_Var "&Pugs::Internals::symbolic_deref") Nothing $
294            (Val . VStr $ sigil:""):exps
295    compile (App (Var var) (Just inv) args) | var == cast "&goto" = do
296        cxt     <- askTCxt
297        funC    <- compile inv
298        argsC   <- enter cxtItemAny $ compile args
299        return $ PApp (TTailCall cxt) funC Nothing argsC
300    compile (App fun inv args) = do
301        cxt     <- askTCxt
302        funC    <- compile fun
303        invC    <- maybeM (return inv) compile
304        argsC   <- enter cxtItemAny $ compile args
305        if isLogicalLazy funC
306            then return $ PApp cxt funC invC (head argsC:map PThunk (tail argsC))
307            else return $ PApp cxt funC invC argsC
308        where
309        -- XXX HACK
310        isLogicalLazy (PExp (PVar "&infix:or"))  = True
311        isLogicalLazy (PExp (PVar "&infix:and")) = True
312        isLogicalLazy (PExp (PVar "&infix:andthen")) = True
313        isLogicalLazy (PExp (PVar "&infix:orelse")) = True
314        isLogicalLazy (PExp (PVar "&infix:||"))  = True
315        isLogicalLazy (PExp (PVar "&infix:&&"))  = True
316        isLogicalLazy (PExp (PVar "&infix://"))  = True
317        isLogicalLazy _ = False
318    compile exp@(Syn "if" _) = compConditional exp
319    compile exp@(Syn "cond" _) = compConditional exp
320    compile (Syn "{}" (x:xs)) = compile $ App (_Var "&postcircumfix:{}") (Just x) xs
321    compile (Syn "[]" (x:xs)) = do
322        compile (App (_Var "&postcircumfix:[]") (Just x) xs)
323    compile (Syn "," exps) = do
324        compile (App (_Var "&infix:,") Nothing exps)
325    -- Minor hack, my $a = [] is parsed as my $a = [Noop], resulting in my $a =
326    -- [undef], which is wrong.
327    compile (Syn "\\[]" [Noop]) = do
328        compile (App (_Var "&circumfix:[]") Nothing [])
329    compile (Syn "\\[]" exps) = do
330        compile (App (_Var "&circumfix:[]") Nothing exps)
331    compile (Syn name@(sigil:"{}") exps) | (sigil ==) `any` "$@%&" = do
332        compile (App (_Var $ "&circumfix:" ++ name) Nothing exps)
333    compile (Syn "\\{}" exps) = do
334        compile (App (_Var "&circumfix:{}") Nothing exps)
335    compile (Syn "*" exps) = do
336        compile (App (_Var "&prefix:*") Nothing exps)
337    compile (Syn "=" [lhs, rhs]) = do
338        lhsC <- enterLValue $ compile lhs
339        rhsC <- enterRValue $ compile rhs
340        return $ PAssign [lhsC] rhsC
341    compile (Syn ":=" exps) = do
342        (lhsC, rhsC) <- enterLValue $ compile exps
343        return $ PBind [lhsC] rhsC
344    compile (Syn syn [lhs, exp]) | last syn == '=' = do
345        let op = "&infix:" ++ init syn
346        compile $ Syn "=" [lhs, App (_Var op) Nothing [lhs, exp]]
347    compile (Syn "but" [obj, block]) =
348        compile $ App (_Var "&Pugs::Internals::but_block") Nothing [obj, block]
349    compile exp@(Syn "namespace" _) = do
350        -- XXX - Is there a better way to wrap Stmts as LValue?
351        compile $ App (Syn "sub"
352            [ Val . VCode $ mkSub
353                { subBody   = Stmts Noop exp
354                , subParams = []
355                }
356            ]) Nothing []
357    -- For PIL2 we want real zone separation, e.g.
358    --   PApp { pNamedArgs = [...], pPositionalArgs = [...], ... }
359    -- For now, using &Pugs::Internals::named_pair is probably ok.
360    compile (Syn "named" kv@[_, _]) = do
361        compile $ App (_Var "&Pugs::Internals::named_pair") Nothing kv
362    compile exp = compError exp
363
364compLoop :: Exp -> Comp PIL_Stmt
365compLoop (Syn name [cond, body]) = do
366    cxt     <- askTCxt
367    condC   <- enter (CxtItem $ mkType "Bool") $ compile cond
368    bodyC   <- enter CxtVoid $ compile body
369    funC    <- compile (_Var $ "&statement_control:" ++ name)
370    return . PStmt . PExp $ PApp cxt funC Nothing [pBlock condC, bodyC]
371compLoop exp = compError exp
372
373{-| Compiles a conditional 'Syn' (@if@ and @unless@) to a call to an
374    appropriate function call (@&statement_control:if@ or
375    @&statement_control:unless@). -}
376compConditional :: Exp -> Comp PIL_LValue
377compConditional (Syn name exps) = do
378    [condC, trueC, falseC] <- compile exps
379    funC    <- compile $ _Var ("&statement_control:" ++ name)
380    cxt     <- askTCxt
381    return $ PApp cxt funC Nothing [condC, PThunk trueC, PThunk falseC]
382compConditional exp = compError exp
383
384_PVar :: Var -> PIL_LValue
385_PVar = PVar . cast
386
387addPad stmt entry = PPad{pStmts=stmt,pScope=SMy,pSyms=[((BS.unpack $ cast $ fst entry),PRawName "...")]}
388{-| Compiles various 'Exp's to 'PIL_Expr's. -}
389instance Compile Exp PIL_Expr where
390    compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest
391    compile (Ann Prag{} rest) = compile rest
392    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest
393    compile (Ann _ rest) = compile rest
394    -- XXX: pragmas?
395    compile (Var name) = return . PExp $ _PVar name
396    compile exp@(Val (VCode _)) = compile $ Syn "sub" [exp]
397    compile (Val val) = fmap PLit $ compile val
398    compile Noop = compile (Val undef)
399    compile (Syn "block" [body]) = do
400        cxt     <- askTCxt
401        bodyC   <- compile body
402        return $ PExp $ PApp cxt (pBlock bodyC) Nothing []
403    compile (Syn "sub" [Val (VCode sub)]) =  do
404        bodyC   <- enter sub $ compile $ case subBody sub of
405            Syn "block" [exp]   -> exp
406            exp                 -> exp
407        paramsC <- compile $ subParams sub
408        return $ PCode (subType sub) paramsC (subLValue sub) (isMulti sub) (foldl addPad bodyC (padToList $ subInnerPad sub))
409    compile (Syn "module" _) = compile Noop
410    compile (Syn "match" exp) = compile $ Syn "rx" exp -- wrong
411    compile (Syn "//" exp) = compile $ Syn "rx" exp
412    compile (Syn "rx" (exp:_)) = compile exp -- XXX WRONG - use PCRE
413    compile (Syn "subst" (exp:_)) = compile exp -- XXX WRONG - use PCRE
414    compile (Syn "trans" (exp:_)) = compile exp -- XXX WRONG
415    compile (Syn "|" [exp]) = compile exp -- XXX WRONG
416    compile (Syn "|<<" [exp]) = compile exp -- XXX WRONG
417    compile exp@(App _ _ _) = fmap PExp $ compile exp
418    compile exp@(Syn _ _) = fmap PExp $ compile exp
419    compile exp = compError exp
420
421compError :: forall a b. Compile a b => a -> Comp b
422compError = die $ "Compile error -- invalid "
423    ++ (show $ typeOf (undefined :: b))
424
425{-| Compiles a 'Val' to a 'PIL_Literal'. -}
426instance Compile Val PIL_Literal where
427    compile (VList vs) = return $ PVal (VList (filter isSimple vs))
428        where
429        isSimple (VRef _) = False
430        isSimple _        = True
431    compile (VRef _) = return $ PVal VUndef
432    compile val = return $ PVal val
433
434-- utility functions
435padSort :: (String, a) -> (String, a) -> Ordering
436padSort (a, _) (b, _)
437    | (head a == ':' && head b == '&') = LT
438    | (head b == ':' && head a == '&') = GT
439    | otherwise = compare a b
440
441varText :: String -> Doc
442varText ('$':name)  = text $ "s__" ++ escaped name
443varText ('@':name)  = text $ "a__" ++ escaped name
444varText ('%':name)  = text $ "h__" ++ escaped name
445varText ('&':name)  = text $ "c__" ++ escaped name
446varText x           = error $ "invalid name: " ++ x
447
448initTEnv :: Eval TEnv
449initTEnv = do
450    initReg <- io $ newTVarIO (0, "")
451    initLbl <- io $ newTVarIO 0
452    return $ MkTEnv
453        { tLexDepth = 0
454        , tTokDepth = 0
455        , tCxt      = tcVoid
456        , tReg      = initReg
457        , tLabel    = initLbl
458        }
Note: See TracBrowser for help on using the browser.